Cosmetic changes to decrease OCamlPro's patch

git-svn-id: http://caml.inria.fr/svn/ocaml/version/4.02@15976 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

driver/compenv.ml

@@ -56,26 +56,28 @@ let first_objfiles = ref []
 let last_objfiles = ref []
 
 (* Check validity of module name *)
-let check_unit_name ppf filename name =
+let is_unit_name name =
   try
     begin match name.[0] with
     | 'A'..'Z' -> ()
     | _ ->
-       Location.print_warning (Location.in_file filename) ppf
-        (Warnings.Bad_module_name name);
        raise Exit;
     end;
     for i = 1 to String.length name - 1 do
       match name.[i] with
       | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
       | _ ->
-         Location.print_warning (Location.in_file filename) ppf
-           (Warnings.Bad_module_name name);
          raise Exit;
     done;
-  with Exit -> ()
+    true
+  with Exit -> false
 ;;
 
+let check_unit_name ppf filename name =
+  if not (is_unit_name name) then
+    Location.print_warning (Location.in_file filename) ppf
+      (Warnings.Bad_module_name name);;
+
 (* Compute name of module from output file name *)
 let module_of_filename ppf inputfile outputprefix =
   let basename = Filename.basename outputprefix in

driver/compenv.mli

@@ -10,7 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* val check_unit_name : Format.formatter -> string -> string -> unit *)
 val module_of_filename : Format.formatter -> string -> string -> string
 
 val output_prefix : string -> string
@@ -35,3 +34,10 @@ type readenv_position =
   Before_args | Before_compile | Before_link
 
 val readenv : Format.formatter -> readenv_position -> unit
+
+(* [is_unit_name name] returns true only if [name] can be used as a
+   correct module name *)
+val is_unit_name : string -> bool
+(* [check_unit_name ppf filename name] prints a warning in [filename]
+   on [ppf] if [name] should not be used as a module name. *)
+val check_unit_name : Format.formatter -> string -> string -> unit

driver/compile.ml

@@ -60,50 +60,44 @@ let implementation ppf sourcefile outputprefix =
   let modulename = module_of_filename ppf sourcefile outputprefix in
   Env.set_unit_name modulename;
   let env = Compmisc.initial_env() in
-  if !Clflags.print_types then begin
-    let comp ast =
-      ast
+  try
+    let (typedtree, coercion) =
+      Pparse.parse_implementation ~tool_name ppf sourcefile
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
       ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ print_if ppf Clflags.dump_typedtree
-          Printtyped.implementation_with_coercion
-      ++ (fun _ -> ());
-      Warnings.check_fatal ();
-      Stypes.dump (Some (outputprefix ^ ".annot"))
+        Printtyped.implementation_with_coercion
     in
-    try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
-    with x ->
-      Stypes.dump (Some (outputprefix ^ ".annot"));
-      raise x
-  end else begin
-    let objfile = outputprefix ^ ".cmo" in
-    let oc = open_out_bin objfile in
-    let comp ast =
-      ast
-      ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ print_if ppf Clflags.dump_source Pprintast.structure
-      ++ Typemod.type_implementation sourcefile outputprefix modulename env
-      ++ print_if ppf Clflags.dump_typedtree
-                  Printtyped.implementation_with_coercion
-      ++ Translmod.transl_implementation modulename
-      ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
-      ++ Simplif.simplify_lambda
-      ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
-      ++ Bytegen.compile_implementation modulename
-      ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
-      ++ Emitcode.to_file oc modulename objfile;
+    if !Clflags.print_types then begin
       Warnings.check_fatal ();
-      close_out oc;
       Stypes.dump (Some (outputprefix ^ ".annot"))
-    in
-    try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
-    with x ->
-      close_out oc;
-      remove_file objfile;
-      Stypes.dump (Some (outputprefix ^ ".annot"));
-      raise x
-  end
+    end else begin
+      let bytecode =
+        (typedtree, coercion)
+        ++ Translmod.transl_implementation modulename
+        ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+        ++ Simplif.simplify_lambda
+        ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+        ++ Bytegen.compile_implementation modulename
+        ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
+      in
+      let objfile = outputprefix ^ ".cmo" in
+      let oc = open_out_bin objfile in
+      try
+        bytecode
+        ++ Emitcode.to_file oc modulename objfile;
+        Warnings.check_fatal ();
+        close_out oc;
+        Stypes.dump (Some (outputprefix ^ ".annot"))
+      with x ->
+        close_out oc;
+        remove_file objfile;
+        raise x
+    end
+  with x ->
+    Stypes.dump (Some (outputprefix ^ ".annot"));
+    raise x
 
 let c_file name =
   Location.input_name := name;

driver/optcompile.ml

@@ -66,22 +66,16 @@ let implementation ppf sourcefile outputprefix =
   let cmxfile = outputprefix ^ ".cmx" in
   let objfile = outputprefix ^ ext_obj in
   let comp ast =
-    if !Clflags.print_types
-    then
+    let (typedtree, coercion) =
       ast
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
       ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ print_if ppf Clflags.dump_typedtree
-          Printtyped.implementation_with_coercion
-      ++ (fun _ -> ())
-    else begin
-      ast
-      ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ print_if ppf Clflags.dump_source Pprintast.structure
-      ++ Typemod.type_implementation sourcefile outputprefix modulename env
-      ++ print_if ppf Clflags.dump_typedtree
-          Printtyped.implementation_with_coercion
+        Printtyped.implementation_with_coercion
+    in
+    if not !Clflags.print_types then begin
+      (typedtree, coercion)
       ++ Translmod.transl_store_implementation modulename
       +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
       +++ Simplif.simplify_lambda

driver/pparse.ml

@@ -20,10 +20,7 @@ exception Error of error
 
 (* Optionally preprocess a source file *)
 
-let preprocess sourcefile =
-  match !Clflags.preprocessor with
-    None -> sourcefile
-  | Some pp ->
+let call_external_preprocessor sourcefile pp =
       let tmpfile = Filename.temp_file "ocamlpp" "" in
       let comm = Printf.sprintf "%s %s > %s"
                                 pp (Filename.quote sourcefile) tmpfile
@@ -34,6 +31,12 @@ let preprocess sourcefile =
       end;
       tmpfile
 
+let preprocess sourcefile =
+  match !Clflags.preprocessor with
+    None -> sourcefile
+  | Some pp -> call_external_preprocessor sourcefile pp
+
+
 let remove_preprocessed inputfile =
   match !Clflags.preprocessor with
     None -> ()
@@ -124,7 +127,7 @@ let apply_rewriters ?restore ~tool_name magic ast =
 
 exception Outdated_version
 
-let file ppf ~tool_name inputfile parse_fun ast_magic =
+let open_and_check_magic inputfile ast_magic =
   let ic = open_in_bin inputfile in
   let is_ast_file =
     try
@@ -138,6 +141,10 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
         Misc.fatal_error "OCaml and preprocessor have incompatible versions"
     | _ -> false
   in
+  (ic, is_ast_file)
+
+let file ppf ~tool_name inputfile parse_fun ast_magic =
+  let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
     try
       if is_ast_file then begin
@@ -159,6 +166,7 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
   close_in ic;
   apply_rewriters ~restore:false ~tool_name ast_magic ast
 
+
 let report_error ppf = function
   | CannotRun cmd ->
       fprintf ppf "Error while running external preprocessor@.\

driver/pparse.mli

@@ -34,3 +34,8 @@ val report_error : formatter -> error -> unit
 
 val parse_implementation: formatter -> tool_name:string -> string -> Parsetree.structure
 val parse_interface: formatter -> tool_name:string -> string -> Parsetree.signature
+
+(* [call_external_preprocessor sourcefile pp] *)
+val call_external_preprocessor : string -> string -> string
+val open_and_check_magic : string -> string -> in_channel * bool
+val read_ast : string -> string -> 'a