Merge pull request #1945 from gasche/stop-after-parse

 new -stop-after-parse option: stop after the parsing phase 

14 files changed, 163 insertions, 38 deletions

diff --git a/Changes b/Changes
index c0f4d9f78f..6c3503494f 100644
--- a/Changes
+++ b/Changes
@@ -170,6 +170,10 @@ Working version
   (Xavier Clerc, review by Gabriel Scherer, Sébastien Hinderer, and
    Xavier Leroy)
 
+- GPR#1945: new "-stop-after parse" option to stop compilation
+  after the parsing pass
+  (Gabriel Scherer, review by Jérémie Dimino)
+
 - GRP#1953: Add locations to attributes in the parsetree.
   (Hugo Heuzard, review by Gabriel Radanne)
 
diff --git a/driver/compenv.ml b/driver/compenv.ml
index f3122a4028..f5e0d2cdd3 100644
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -105,6 +105,10 @@ type readenv_position =
    or ':', '|', ';', ' ' or ',' *)
 exception SyntaxError of string
 
+let print_error ppf msg =
+  Location.print_warning Location.none ppf
+    (Warnings.Bad_env_variable ("OCAMLPARAM", msg))
+
 let parse_args s =
   let args =
     let len = String.length s in
@@ -148,25 +152,22 @@ let setter ppf f name options s =
     in
     List.iter (fun b -> b := f bool) options
   with Not_found ->
-    Location.print_warning Location.none ppf
-      (Warnings.Bad_env_variable ("OCAMLPARAM",
-                                  Printf.sprintf "bad value for %s" name))
+    Printf.ksprintf (print_error ppf)
+      "bad value %s for %s" s name
 
 let int_setter ppf name option s =
   try
     option := int_of_string s
   with _ ->
-    Location.print_warning Location.none ppf
-      (Warnings.Bad_env_variable
-         ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
+    Printf.ksprintf (print_error ppf)
+      "non-integer parameter %s for %S" s name
 
 let int_option_setter ppf name option s =
   try
     option := Some (int_of_string s)
   with _ ->
-    Location.print_warning Location.none ppf
-      (Warnings.Bad_env_variable
-         ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
+    Printf.ksprintf (print_error ppf)
+      "non-integer parameter %s for %S" s name
 
 (*
 let float_setter ppf name option s =
@@ -185,9 +186,8 @@ let check_bool ppf name s =
   | "0" -> false
   | "1" -> true
   | _ ->
-    Location.print_warning Location.none ppf
-      (Warnings.Bad_env_variable ("OCAMLPARAM",
-                                  Printf.sprintf "bad value for %s" name));
+    Printf.ksprintf (print_error ppf)
+      "bad value %s for %s" s name;
     false
 
 (* 'can-discard=' specifies which arguments can be discarded without warning
@@ -260,12 +260,8 @@ let read_one_param ppf position name v =
       begin match F.parse_no_error v inline_threshold with
       | F.Ok -> ()
       | F.Parse_failed exn ->
-          let error =
-            Printf.sprintf "bad syntax for \"inline\": %s"
-              (Printexc.to_string exn)
-          in
-          Location.print_warning Location.none ppf
-            (Warnings.Bad_env_variable ("OCAMLPARAM", error))
+          Printf.ksprintf (print_error ppf)
+            "bad syntax %s for \"inline\": %s" v (Printexc.to_string exn)
       end
 
   | "inline-toplevel" ->
@@ -348,10 +344,9 @@ let read_one_param ppf position name v =
   | "color" ->
       begin match parse_color_setting v with
       | None ->
-        Location.print_warning Location.none ppf
-          (Warnings.Bad_env_variable ("OCAMLPARAM",
-           "bad value for \"color\", \
-            (expected \"auto\", \"always\" or \"never\")"))
+        Printf.ksprintf (print_error ppf)
+          "bad value %s for \"color\", \
+           (expected \"auto\", \"always\" or \"never\")" v
       | Some setting -> color := Some setting
       end
 
@@ -426,10 +421,24 @@ let read_one_param ppf position name v =
 
   | "plugin" -> !load_plugin v
 
+  | "stop-after" ->
+    let module P = Clflags.Compiler_pass in
+    begin match P.of_string v with
+    | None ->
+        Printf.ksprintf (print_error ppf)
+          "bad value %s for option \"stop-after\" (expected one of: %s)"
+          v (String.concat ", " P.pass_names)
+    | Some pass ->
+        Clflags.stop_after := Some pass;
+        begin match pass with
+        | P.Parsing | P.Typing ->
+            compile_only := true
+        end;
+    end
   | _ ->
     if not (List.mem name !can_discard) then begin
       can_discard := name :: !can_discard;
-      Printf.eprintf
+      Printf.ksprintf (print_error ppf)
         "Warning: discarding value of variable %S in OCAMLPARAM\n%!"
         name
     end
@@ -441,9 +450,8 @@ let read_OCAMLPARAM ppf position =
       try
         parse_args s
       with SyntaxError s ->
-         Location.print_warning Location.none ppf
-           (Warnings.Bad_env_variable ("OCAMLPARAM", s));
-         [],[]
+        print_error ppf s;
+        [],[]
     in
     List.iter (fun (name, v) -> read_one_param ppf position name v)
       (match position with
diff --git a/driver/compile_common.ml b/driver/compile_common.ml
index 9be49396df..b246a57c3c 100644
--- a/driver/compile_common.ml
+++ b/driver/compile_common.ml
@@ -112,11 +112,13 @@ let implementation ~tool_name ~native ~backend ~sourcefile ~outputprefix =
   in
   Profile.record_call info.sourcefile @@ fun () ->
   let parsed = parse_impl info in
-  let typed = typecheck_impl info parsed in
-  if not !Clflags.print_types then begin
-    let exceptionally () =
-      List.iter (fun suf -> remove_file (suf info)) sufs;
-    in
-    Misc.try_finally ~exceptionally (fun () -> backend info typed)
+  if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin
+    let typed = typecheck_impl info parsed in
+    if Clflags.(should_stop_after Compiler_pass.Typing) then () else begin
+      let exceptionally () =
+        List.iter (fun suf -> remove_file (suf info)) sufs;
+      in
+      Misc.try_finally ~exceptionally (fun () -> backend info typed)
+    end;
   end;
   Warnings.check_fatal ();
diff --git a/driver/main.ml b/driver/main.ml
index b8c11a240d..a81d35651f 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -41,7 +41,22 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _dllpath s = dllpaths := !dllpaths @ [s]
   let _for_pack s = for_package := Some s
   let _g = set debug
-  let _i () = print_types := true; compile_only := true
+  let _i () =
+    print_types := true;
+    compile_only := true;
+    stop_after := Some Compiler_pass.Typing;
+    ()
+  let _stop_after pass =
+    let module P = Compiler_pass in
+    begin match P.of_string pass with
+    | None -> () (* this should not occur as we use Arg.Symbol *)
+    | Some pass ->
+        stop_after := Some pass;
+        begin match pass with
+        | P.Parsing | P.Typing ->
+            compile_only := true
+        end;
+    end
   let _I s = include_dirs := s :: !include_dirs
   let _impl = impl
   let _intf = intf
@@ -156,11 +171,17 @@ let main () =
         (List.filter (fun x -> !x)
            [make_archive;make_package;compile_only;output_c_object])
         > 1
-    then
-      if !print_types then
-        fatal "Option -i is incompatible with -pack, -a, -output-obj"
-      else
+    then begin
+      let module P = Clflags.Compiler_pass in
+      match !stop_after with
+      | None ->
         fatal "Please specify at most one of -pack, -a, -c, -output-obj";
+      | Some (P.Parsing | P.Typing) ->
+          Printf.ksprintf fatal
+            "Options -i and -stop-after (%s)\
+             are  incompatible with -pack, -a, -output-obj"
+            (String.concat "|" P.pass_names)
+    end;
     if !make_archive then begin
       Compmisc.init_path false;
 
diff --git a/driver/main_args.ml b/driver/main_args.ml
index 42a1fc4608..afc6238168 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -83,6 +83,11 @@ let mk_dllpath f =
   "<dir>  Add <dir> to the run-time search path for shared libraries"
 ;;
 
+let mk_stop_after f =
+  "-stop-after", Arg.Symbol (Clflags.Compiler_pass.pass_names, f),
+  " Stop after the given compilation pass."
+;;
+
 let mk_dtypes f =
   "-dtypes", Arg.Unit f, " (deprecated) same as -annot"
 ;;
@@ -867,6 +872,7 @@ module type Compiler_options = sig
   val _config_var : string -> unit
   val _for_pack : string -> unit
   val _g : unit -> unit
+  val _stop_after : string -> unit
   val _i : unit -> unit
   val _impl : string -> unit
   val _intf : string -> unit
@@ -1059,6 +1065,7 @@ struct
     mk_dtypes F._annot;
     mk_for_pack_byt F._for_pack;
     mk_g_byt F._g;
+    mk_stop_after F._stop_after;
     mk_i F._i;
     mk_I F._I;
     mk_impl F._impl;
@@ -1224,6 +1231,7 @@ struct
     mk_dtypes F._annot;
     mk_for_pack_opt F._for_pack;
     mk_g_opt F._g;
+    mk_stop_after F._stop_after;
     mk_i F._i;
     mk_I F._I;
     mk_impl F._impl;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index da683d321a..3a9cc82495 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -73,6 +73,7 @@ module type Compiler_options = sig
   val _config_var : string -> unit
   val _for_pack : string -> unit
   val _g : unit -> unit
+  val _stop_after : string -> unit
   val _i : unit -> unit
   val _impl : string -> unit
   val _intf : string -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 73f1b3554e..2a0f6ab4cd 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -56,7 +56,22 @@ module Options = Main_args.Make_optcomp_options (struct
   let _config_var = Misc.show_config_variable_and_exit
   let _for_pack s = for_package := Some s
   let _g = set debug
-  let _i () = print_types := true; compile_only := true
+  let _i () =
+    print_types := true;
+    compile_only := true;
+    stop_after := Some Compiler_pass.Typing;
+    ()
+  let _stop_after pass =
+    let module P = Compiler_pass in
+    begin match P.of_string pass with
+    | None -> () (* this should not occur as we use Arg.Symbol *)
+    | Some pass ->
+        stop_after := Some pass;
+        begin match pass with
+        | P.Parsing | P.Typing ->
+            compile_only := true
+        end;
+    end
   let _I dir = include_dirs := dir :: !include_dirs
   let _impl = impl
   let _inline spec =
diff --git a/man/ocamlc.m b/man/ocamlc.m
index 08af3b5d1b..883c31187f 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -620,6 +620,12 @@ then the
 .B d
 suffix is supported and gives a debug version of the runtime.
 .TP
+.BI \-stop\-after \ pass
+Stop compilation after the given compilation pass. The currently
+supported passes are:
+.BR parsing ,
+.BR typing .
+.TP
 .B \-safe\-string
 Enforce the separation between types
 .BR string \ and\  bytes ,
diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index 81617233ec..4538ea3c8b 100644
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -569,6 +569,12 @@ code for the source file
 is saved in the file
 .IR x .s.
 .TP
+.BI \-stop\-after \ pass
+Stop compilation after the given compilation pass. The currently
+supported passes are:
+.BR parsing ,
+.BR typing .
+.TP
 .B \-safe\-string
 Enforce the separation between types
 .BR string \ and\  bytes ,
diff --git a/manual/manual/cmds/unified-options.etex b/manual/manual/cmds/unified-options.etex
index fd15c5c651..cc5c09d1dd 100644
--- a/manual/manual/cmds/unified-options.etex
+++ b/manual/manual/cmds/unified-options.etex
@@ -606,6 +606,12 @@ runtime, which is useful for debugging pointer problems in low-level
 code such as C stubs.
 }%notop
 
+\notop{
+\item["-stop-after" \var{pass}]
+Stop compilation after the given compilation pass. The currently
+supported passes are: "parsing", "typing".
+}%notop
+
 \nat{%
 \item["-S"]
 Keep the assembly code produced during the compilation. The assembly
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index d113358c02..6f4965880e 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -63,6 +63,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _dtypes = option "-dtypes"
   let _for_pack = option_with_arg "-for-pack"
   let _g = option "-g"
+  let _stop_after = option_with_arg "-stop-after"
   let _i = option "-i"
   let _I s = option_with_arg "-I" s
   let _impl s = with_impl := true; option_with_arg "-impl" s
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 88b84c819c..eae738ae5a 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -65,6 +65,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _config_var s = option_with_arg "-config-var" s
   let _for_pack s = option_with_arg "-for-pack" s
   let _g = option "-g"
+  let _stop_after = option_with_arg "-stop-after"
   let _i = option "-i"
   let _I s = option_with_arg "-I" s
   let _impl s = with_impl := true; option_with_arg "-impl" s
diff --git a/utils/clflags.ml b/utils/clflags.ml
index af942b6290..cc72970d06 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -376,6 +376,42 @@ let color = ref None ;; (* -color *)
 
 let unboxed_types = ref false
 
+(* This is used by the -stop-after option. *)
+module Compiler_pass = struct
+  (* If you add a new pass, the following must be updated:
+     - the variable `passes` below
+     - the manpages in man/ocaml{c,opt}.m
+     - the manual manual/manual/cmds/unified-options.etex
+  *)
+  type t = Parsing | Typing
+
+  let to_string = function
+    | Parsing -> "parsing"
+    | Typing -> "typing"
+
+  let of_string = function
+    | "parsing" -> Some Parsing
+    | "typing" -> Some Typing
+    | _ -> None
+
+  let rank = function
+    | Parsing -> 0
+    | Typing -> 1
+
+  let passes = [
+    Parsing;
+    Typing;
+  ]
+  let pass_names = List.map to_string passes
+end
+
+let stop_after = ref None (* -stop-after *)
+
+let should_stop_after pass =
+  match !stop_after with
+  | None -> false
+  | Some stop -> Compiler_pass.rank stop <= Compiler_pass.rank pass
+
 module String = Misc.Stdlib.String
 
 let arg_spec = ref []
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 639ae5cc48..feaa6e9f51 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -217,6 +217,16 @@ val color : Misc.Color.setting option ref
 
 val unboxed_types : bool ref
 
+module Compiler_pass : sig
+  type t = Parsing | Typing
+  val of_string : string -> t option
+  val to_string : t -> string
+  val passes : t list
+  val pass_names : string list
+end
+val stop_after : Compiler_pass.t option ref
+val should_stop_after : Compiler_pass.t -> bool
+
 val arg_spec : (string * Arg.spec * string) list ref
 
 (* [add_arguments __LOC__ args] will add the arguments from [args] at