check consistency of Yacc and Menhir parsers + OCAML_PARSERS variable

The compiler calls several parsers and fails if the parsed ASTs do not
coincide. You can set the environment variable OCAML_PARSERS to select
the parser(s) to use, as a space-separated list of parser names.

      OCAML_PARSERS="yacc"
      OCAML_PARSERS="menhir"
      OCAML_PARSERS="yacc menhir"

1 files changed, 73 insertions, 9 deletions

diff --git a/driver/pparse.ml b/driver/pparse.ml
index 880bca5eff..ba973d86ba 100644
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -165,8 +165,13 @@ let parse (type a) (kind : a ast_kind) lexbuf : a =
   | Structure -> Parse.implementation lexbuf
   | Signature -> Parse.interface lexbuf
 
+let parse_menhir (type a) (kind : a ast_kind) lexbuf : a =
+  match kind with
+  | Structure -> Parse.implementation_menhir lexbuf
+  | Signature -> Parse.interface_menhir lexbuf
+
 let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
-             (kind : a ast_kind) =
+             (kind : a ast_kind) : a =
   let ast_magic = magic_of_kind kind in
   let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
@@ -211,12 +216,12 @@ let () =
       | _ -> None
     )
 
-let parse_file ~tool_name invariant_fun apply_hooks kind sourcefile =
+let parse_file ~tool_name invariant_fun apply_hooks parse kind sourcefile =
   Location.input_name := sourcefile;
   let inputfile = preprocess sourcefile in
   let ast =
     Misc.try_finally (fun () ->
-        file_aux ~tool_name inputfile (parse kind) invariant_fun kind
+        file_aux ~tool_name inputfile parse invariant_fun kind
       )
       ~always:(fun () -> remove_preprocessed inputfile)
   in
@@ -230,11 +235,70 @@ module InterfaceHooks = Misc.MakeHooks(struct
     type t = Parsetree.signature
   end)
 
+let compare_parsers parsers sourcefile print use =
+  let asts = List.map (fun (name, parse) -> (name, use name parse)) parsers in
+  match asts with
+  | [] -> invalid_arg "run_parser: empty parser list"
+  | (name1, ast1) :: _ ->
+      begin match List.find (fun (_, ast) -> ast <> ast1) asts with
+      | (name2, _ast2) ->
+        let output (name, ast) =
+          let out = open_out (String.concat "." [sourcefile; name; "ast"]) in
+          let ppf = Format.formatter_of_out_channel out in
+          print ppf ast;
+          Format.pp_print_flush ppf ();
+          close_out out;
+        in
+        List.iter output asts;
+        Printf.kprintf failwith
+          "Parsers '%s' and '%s' returned different ASTs on '%s'. \
+           See files %s.{%s,%s}.ast for details."
+          name1 name2 sourcefile
+          sourcefile name1 name2;
+      | exception Not_found -> ast1
+      end
+
+let choose_parsers parser_table =
+  match Sys.getenv "OCAML_PARSERS" with
+  | exception Not_found -> parser_table
+  | env_param ->
+      let env_parsers = List.rev (Misc.rev_split_words env_param) in
+      let get_parser name =
+        match List.assoc name parser_table with
+        | exception Not_found ->
+            let available_parsers =
+              String.concat " " (List.map fst parser_table) in
+            Printf.kprintf failwith
+              "%S is not a valid parser name,\
+               use a space-separated list among \"%s\""
+              name available_parsers
+        | parse -> (name, parse)
+      in
+      List.map get_parser env_parsers
+
+let yacc = "yacc"
+let menhir = "menhir"
+
 let parse_implementation ~tool_name sourcefile =
-  Profile.record_call "parsing" (fun () ->
-    parse_file ~tool_name Ast_invariants.structure
-      ImplementationHooks.apply_hooks Structure sourcefile)
+  let parse = choose_parsers [
+      (yacc, parse Structure);
+      (menhir, parse_menhir Structure)
+    ] in
+  compare_parsers parse sourcefile Printast.implementation
+    (fun name parse ->
+       Profile.record_call (Printf.sprintf "parsing(%s)" name)
+         (fun () ->
+            parse_file ~tool_name Ast_invariants.structure
+              ImplementationHooks.apply_hooks parse Structure sourcefile))
+
 let parse_interface ~tool_name sourcefile =
-  Profile.record_call "parsing" (fun () ->
-    parse_file ~tool_name Ast_invariants.signature
-      InterfaceHooks.apply_hooks Signature sourcefile)
+  let parse = choose_parsers [
+      (yacc, parse Signature);
+      (menhir, parse_menhir Signature)
+    ] in
+  compare_parsers parse sourcefile Printast.interface
+    (fun name parse ->
+       Profile.record_call (Printf.sprintf "parsing(%s)" name)
+         (fun () ->
+            parse_file ~tool_name Ast_invariants.signature
+              InterfaceHooks.apply_hooks parse Signature sourcefile))