The OCaml version of the negative tests is running.

bench/src/Makefile

@@ -7,6 +7,7 @@ all:
 	$(OCAMLBUILD) $(TARGET)
 
 test: all
+	$(MAKE) -C ../../src bootstrap
 	./$(TARGET)
 
 clean:

bench/src/_tags

 true: \
+  warn(A-44), \
   package(str), \
   package(unix), \
   package(functory)

bench/src/auxiliary.ml

@@ -117,7 +117,7 @@ let rec groups1 eq groups x group ys =
       if eq x y then
         groups1 eq groups x (y :: group) ys
       else
-        groups0 eq (group :: groups) (y :: ys)
+        groups0 eq (List.rev group :: groups) (y :: ys)
 
 and groups0 eq groups ys =
   match ys with
@@ -141,6 +141,13 @@ let chop_numeric_suffix s =
 let equal_up_to_numeric_suffix s1 s2 =
   chop_numeric_suffix s1 = chop_numeric_suffix s2
 
+let dash_numeric_suffix =
+  Str.regexp "-[0-9]*$"
+
+let chop_dash_numeric_suffix s =
+  let offset = Str.search_forward dash_numeric_suffix s 0 in
+  String.sub s 0 offset
+
 (* [sep ss] separates the strings in the list [ss] with a space,
    and concatenates everything, producing a single string. *)
 

bench/src/test.ml

@@ -7,6 +7,23 @@ open Auxiliary
 
 (* -------------------------------------------------------------------------- *)
 
+(* Settings. *)
+
+(* 0 is minimal verbosity;
+   1 shows some progress messages;
+   2 is maximal verbosity. *)
+
+let verbosity =
+  1
+
+let log level format =
+  kprintf (fun s ->
+    if level <= verbosity then
+      print_string s
+  ) format
+
+(* -------------------------------------------------------------------------- *)
+
 (* Paths. *)
 
 let root =
@@ -19,21 +36,21 @@ let src =
 let bad =
   root ^ "/bench/bad"
 
+(* We use the stage 2 executable (i.e., Menhir compiled by Menhir)
+   because it has better syntax error messages and we want to test
+   them. *)
+(* The standard library is the one in [src], viewed from [test/bad]
+   or [test/good], so we use the relative path [../../src]. *)
 let menhir =
-  src ^ "/_stage1/menhir.native --stdlib " ^ src
+  src ^ "/_stage2/menhir.native --stdlib ../../src"
 
 (* -------------------------------------------------------------------------- *)
 
 (* Test files and groups of test files. *)
 
 let id basenames =
-  (* A name for a group of test files. *)
-  if length basenames = 1 then
-    hd basenames
-  else
-    sprintf "%s[0-9] (%d files)"
-      (chop_numeric_suffix (hd basenames))
-      (length basenames)
+  (* A name for a nonempty group of test files. *)
+  hd basenames
 
 let thisfile basenames =
   if length basenames > 1 then "these input files" else "this input file"
@@ -55,11 +72,17 @@ type input =
 
 let print_input = function
   | NegativeTest basenames ->
-      hd basenames
+      id basenames
 
 type outcome =
-  | Success
-  | Failure of string (* message *)
+  | OK
+  | Fail of string (* message *)
+
+let print_outcome = function
+  | OK ->
+      ""
+  | Fail msg ->
+      msg
 
 type output =
   input * outcome
@@ -67,36 +90,57 @@ type output =
 type inputs = input list
 type outputs = output list
 
-let process input : output =
-  match input with
+let prepare (bits : string list) : command =
+  let cmd = sep bits in
+  log 2 "%s\n%!" cmd;
+  cmd
+
+let process_negative_test basenames : unit =
+  (* Informational message. *)
+  let id = id basenames in
+  log 1 "Testing %s...\n%!" id;
+
+  (* A --base option is needed for groups of several files. *)
+  let base = if length basenames > 1 then sprintf "--base %s" id else "" in
+
+  (* The output is stored in this file. *)
+  let result = id ^ ".result" in
+
+  (* Run Menhir in the directory bad/. *)
+  let cmd = prepare (
+    "cd" :: bad :: "&&" ::
+    menhir :: base :: mlys basenames @ sprintf ">%s" result :: "2>&1" :: []
+  ) in
+
+  if command cmd = 0 then begin
+    log 1 "[FAIL] %s\n%!" id;
+    fail "menhir should not accept %s.\n" (thisfile basenames)
+  end;
+
+  (* Check that the output coincides with what was expected. *)
+  let expected = id ^ ".expected" in
+  let cmd = prepare (
+    "cd" :: bad :: "&&" ::
+    "diff" :: expected :: result :: []
+  ) in
+  if succeeds cmd then
+    log 1 "[OK] %s\n%!" id
+  else begin
+    log 1 "[FAIL] %s\n%!" id;
+    fail "menhir correctly rejects %s, with incorrect output.\n(%s)\n"
+      (thisfile basenames)
+      cmd
+  end
 
-  (* A negative test. *)
-  | NegativeTest basenames ->
-
-      (* Informational message. *)
-      let id = id basenames in
-      printf "Testing %s...\n%!" id;
-
-      (* A --base option is needed for groups of several files. *)
-      let base =
-        if length basenames > 1 then
-          sprintf "--base %s" (chop_numeric_suffix (hd basenames))
-        else
-          ""
-      in
-
-      (* Run Menhir. *)
-      let command = sep (menhir :: base :: mlys basenames) in
-
-      if succeeds command then begin
-        printf "[FAIL] %s\n%!" id;
-        let msg = sprintf "menhir should not accept %s." (thisfile basenames) in
-        input, Failure msg
-      end
-      else begin
-        printf "[OK] %s\n%!" id;
-        input, Success
-      end
+let process input : output =
+  try
+    begin match input with
+    | NegativeTest basenames ->
+        process_negative_test basenames
+    end;
+    input, OK
+  with Failure msg ->
+    input, Fail msg
 
 (* -------------------------------------------------------------------------- *)
 
@@ -106,7 +150,7 @@ let run (inputs : inputs) : outputs =
   Functory.Cores.set_number_of_cores (get_number_of_cores ());
   (* Functory.Control.set_debug true; *)
   flush stdout; flush stderr;
-  let outputs = Functory.Cores.map process inputs in
+  let outputs = Functory.Cores.map ~f:process inputs in
   outputs
 
 (* -------------------------------------------------------------------------- *)
@@ -134,11 +178,11 @@ let outputs : outputs =
   run negative
 
 let successful, failed =
-  partition (fun (_, o) -> o = Success) outputs
+  partition (fun (_, o) -> o = OK) outputs
 
 let () =
   printf "%d out of %d tests are successful.\n"
     (length successful) (length inputs);
   failed |> iter (fun (input, outcome) ->
-    printf "[FAIL] %s\n" (print_input input)
+    printf "\n[FAIL] %s\n%s" (print_input input) (print_outcome outcome)
   )