Merge pull request #4 from janestreet/patch/ocamlnat4.02.3-1

make ocamlnat build again

6 files changed, 143 insertions, 42 deletions

diff --git a/Makefile b/Makefile
index ead65207e3..65ff626491 100644
--- a/Makefile
+++ b/Makefile
@@ -103,15 +103,16 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
 TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \
   toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
 
+OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/opttoploop.cmo \
+  toplevel/opttopdirs.cmo toplevel/opttopmain.cmo
+
 BYTESTART=driver/main.cmo
 
 OPTSTART=driver/optmain.cmo
 
 TOPLEVELSTART=toplevel/topstart.cmo
 
-NATTOPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \
-  toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \
-  toplevel/opttopmain.cmo toplevel/opttopstart.cmo
+OPTTOPLEVELSTART=toplevel/opttopstart.cmo
 
 PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
 
@@ -367,8 +368,10 @@ installoptopt:
 	cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \
 	   compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \
 	   compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \
+	   compilerlibs/ocamlopttoplevel.cmxa compilerlibs/ocamlopttoplevel.a \
 	   $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \
 	   $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \
+           $(OPTTOPLEVELSTART:.cmo=.cmx) $(OPTTOPLEVELSTART:.cmo=.o) \
 	   $(INSTALL_COMPLIBDIR)
 	cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \
 	   ocamloptcomp.a
@@ -434,9 +437,17 @@ partialclean::
 
 # The native toplevel
 
-ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
-	$(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \
-	           $(NATTOPOBJS:.cmo=.cmx) -linkall
+compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx)
+	$(CAMLOPT) -a -o $@ $(OPTTOPLEVEL:.cmo=.cmx)
+partialclean::
+	rm -f compilerlibs/ocamlopttoplevel.cmxa
+
+ocamlnat: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+	  otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlopttoplevel.cmxa $(OPTTOPLEVELSTART:.cmo=.cmx)
+	$(CAMLOPT) $(LINKFLAGS) -linkall -o ocamlnat \
+	  otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlcommon.cmxa \
+	  compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamlopttoplevel.cmxa \
+	  $(OPTTOPLEVELSTART:.cmo=.cmx)
 
 toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
 
diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index 9741d17bea..4298e886a1 100644
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -34,6 +34,15 @@ let dir_directory s =
   Config.load_path := d :: !Config.load_path
 
 let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
+(* To remove a directory from the load path *)
+let dir_remove_directory s =
+  let d = expand_directory Config.standard_library s in
+  Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path
+
+let _ =
+  Hashtbl.add directive_table "remove_directory"
+    (Directive_string dir_remove_directory)
+
 let _ = Hashtbl.add directive_table "show_dirs"
   (Directive_none
      (fun () ->
@@ -135,7 +144,7 @@ let find_printer_type ppf lid =
 let dir_install_printer ppf lid =
   try
     let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
-    let v = eval_path path in
+    let v = eval_path !toplevel_env path in
     let print_function =
       if is_old_style then
         (fun formatter repr -> Obj.obj v (Obj.obj repr))
diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli
index 8caf71d443..d124428ab9 100644
--- a/toplevel/opttopdirs.mli
+++ b/toplevel/opttopdirs.mli
@@ -16,6 +16,7 @@ open Format
 
 val dir_quit : unit -> unit
 val dir_directory : string -> unit
+val dir_remove_directory : string -> unit
 val dir_cd : string -> unit
 val dir_load : formatter -> string -> unit
 val dir_use : formatter -> string -> unit
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index d21860a871..039beaec02 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -20,6 +20,7 @@ open Parsetree
 open Types
 open Typedtree
 open Outcometree
+open Ast_helper
 
 type res = Ok of Obj.t | Err of string
 type evaluation_outcome = Result of Obj.t | Exception of exn
@@ -74,12 +75,15 @@ let rec eval_path = function
   | Papply(p1, p2) ->
       fatal_error "Toploop.eval_path"
 
+let eval_path env path =
+  eval_path (Env.normalize_path (Some Location.none) env path)
+
 (* To print values *)
 
 module EvalPath = struct
   type valu = Obj.t
   exception Error
-  let eval_path p = try eval_path p with _ -> raise Error
+  let eval_path env p = try eval_path env p with _ -> raise Error
   let same_value v1 v2 = (v1 == v2)
 end
 
@@ -105,7 +109,13 @@ let outval_of_value env obj ty =
 let print_value env obj ppf ty =
   !print_out_value ppf (outval_of_value env obj ty)
 
+type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
 let install_printer = Printer.install_printer
+let install_generic_printer = Printer.install_generic_printer
+let install_generic_printer' = Printer.install_generic_printer'
 let remove_printer = Printer.remove_printer
 
 (* Hooks for parsing functions *)
@@ -117,6 +127,25 @@ let print_error = Location.print_error
 let print_warning = Location.print_warning
 let input_name = Location.input_name
 
+let parse_mod_use_file name lb =
+  let modname =
+    String.capitalize (Filename.chop_extension (Filename.basename name))
+  in
+  let items =
+    List.concat
+      (List.map
+         (function Ptop_def s -> s | Ptop_dir _ -> [])
+         (!parse_use_file lb))
+  in
+  [ Ptop_def
+      [ Str.module_
+          (Mb.mk
+             (Location.mknoloc modname)
+             (Mod.structure items)
+          )
+       ]
+   ]
+
 (* Hooks for initialization *)
 
 let toplevel_startup_hook = ref (fun () -> ())
@@ -153,7 +182,9 @@ let load_lambda ppf (size, lam) =
 
 (* Print the outcome of an evaluation *)
 
-let rec pr_item env = function
+let rec pr_item env items =
+  Printtyp.hide_rec_items items;
+  match items with
   | Sig_value(id, decl) :: rem ->
       let tree = Printtyp.tree_of_value_description id decl in
       let valopt =
@@ -175,8 +206,8 @@ let rec pr_item env = function
   | Sig_typext(id, ext, es) :: rem ->
       let tree = Printtyp.tree_of_extension_constructor id ext es in
       Some (tree, None, rem)
-  | Sig_module(id, mty, rs) :: rem ->
-      let tree = Printtyp.tree_of_module id mty rs in
+  | Sig_module(id, md, rs) :: rem ->
+      let tree = Printtyp.tree_of_module id md.md_type rs in
       Some (tree, None, rem)
   | Sig_modtype(id, decl) :: rem ->
       let tree = Printtyp.tree_of_modtype_declaration id decl in
@@ -225,9 +256,10 @@ let execute_phrase print_outcome ppf phr =
       phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
       Compilenv.reset ?packname:None !phrase_name;
       Typecore.reset_delayed_checks ();
-      let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
-      in
+      let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
       if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
+      let sg' = Typemod.simplify_signature sg in
+      ignore (Includemod.signatures oldenv sg sg');
       Typecore.force_delayed_checks ();
       let res = Translmod.transl_store_phrases !phrase_name str in
       Warnings.check_fatal ();
@@ -239,16 +271,14 @@ let execute_phrase print_outcome ppf phr =
           | Result v ->
               Compilenv.record_global_approx_toplevel ();
               if print_outcome then
+                Printtyp.wrap_printing_env oldenv (fun () ->
                 match str.str_items with
-                | [ {str_desc = Tstr_eval exp} ] ->
+                | [ {str_desc = Tstr_eval (exp, _attrs)} ] ->
                     let outv = outval_of_value newenv v exp.exp_type in
                     let ty = Printtyp.tree_of_type_scheme exp.exp_type in
                     Ophr_eval (outv, ty)
                 | [] -> Ophr_signature []
-                | _ ->
-                    Ophr_signature (item_list newenv
-                                             (Typemod.simplify_signature sg))
-
+                | _ -> Ophr_signature (item_list newenv sg'))
               else Ophr_signature []
           | Exception exn ->
               toplevel_env := oldenv;
@@ -267,19 +297,26 @@ let execute_phrase print_outcome ppf phr =
         toplevel_env := oldenv; raise x
       end
   | Ptop_dir(dir_name, dir_arg) ->
-      try
-        match (Hashtbl.find directive_table dir_name, dir_arg) with
-        | (Directive_none f, Pdir_none) -> f (); true
-        | (Directive_string f, Pdir_string s) -> f s; true
-        | (Directive_int f, Pdir_int n) -> f n; true
-        | (Directive_ident f, Pdir_ident lid) -> f lid; true
-        | (Directive_bool f, Pdir_bool b) -> f b; true
-        | (_, _) ->
-            fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
-            false
-      with Not_found ->
-        fprintf ppf "Unknown directive `%s'.@." dir_name;
-        false
+      let d =
+        try Some (Hashtbl.find directive_table dir_name)
+        with Not_found -> None
+      in
+      begin match d with
+      | None ->
+          fprintf ppf "Unknown directive `%s'.@." dir_name;
+          false
+      | Some d ->
+          match d, dir_arg with
+          | Directive_none f, Pdir_none -> f (); true
+          | Directive_string f, Pdir_string s -> f s; true
+          | Directive_int f, Pdir_int n -> f n; true
+          | Directive_ident f, Pdir_ident lid -> f lid; true
+          | Directive_bool f, Pdir_bool b -> f b; true
+          | _ ->
+              fprintf ppf "Wrong type of argument for directive `%s'.@."
+                dir_name;
+              false
+      end
 
 (* Temporary assignment to a reference *)
 
@@ -294,11 +331,25 @@ let protect r newval body =
     r := oldval;
     raise x
 
-(* Read and execute commands from a file *)
+(* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
 
-let use_file ppf name =
+let preprocess_phrase ppf phr =
+  let phr =
+    match phr with
+    | Ptop_def str ->
+        let str =
+          Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
+        in
+        Ptop_def str
+    | phr -> phr
+  in
+  if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+  if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+  phr
+
+let use_file ppf wrap_mod name =
   try
     let (filename, ic, must_close) =
       if name = "" then
@@ -318,10 +369,12 @@ let use_file ppf name =
         try
           List.iter
             (fun ph ->
-              if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
-              if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
+              let ph = preprocess_phrase ppf ph in
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
-            (!parse_use_file lb);
+            (if wrap_mod then
+               parse_mod_use_file name lb
+             else
+               !parse_use_file lb);
           true
         with
         | Exit -> false
@@ -331,6 +384,9 @@ let use_file ppf name =
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
+let mod_use_file ppf name = use_file ppf true name
+let use_file ppf name = use_file ppf false name
+
 let use_silently ppf name =
   protect use_print_results false (fun () -> use_file ppf name)
 
@@ -345,8 +401,8 @@ let read_input_default prompt buffer len =
   try
     while true do
       if !i >= len then raise Exit;
-      let c = input_char stdin in
-      buffer.[!i] <- c;
+      let c = input_char Pervasives.stdin in
+      Bytes.set buffer !i c;
       incr i;
       if c = '\n' then raise Exit;
     done;
@@ -418,6 +474,7 @@ let initialize_toplevel_env () =
 exception PPerror
 
 let loop ppf =
+  Location.formatter_for_warnings := ppf;
   fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
@@ -433,6 +490,8 @@ let loop ppf =
       Location.reset();
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
+      let phr = preprocess_phrase ppf phr  in
+      Env.reset_cache_toplevel ();
       if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
       if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
       ignore(execute_phrase true ppf phr)
@@ -443,7 +502,7 @@ let loop ppf =
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
-(* Execute a script *)
+(* Execute a script.  If [name] is "", read the script from stdin. *)
 
 let run_script ppf name args =
   let len = Array.length args in
diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index 2236255818..24b44e08aa 100644
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -47,12 +47,17 @@ val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
            phrase executed with no errors and [false] otherwise.
            First bool says whether the values and types of the results
            should be printed. Uncaught exceptions are always printed. *)
+val preprocess_phrase : formatter -> Parsetree.toplevel_phrase ->  Parsetree.toplevel_phrase
+        (* Preprocess the given toplevel phrase using regular and ppx
+           preprocessors. Return the updated phrase. *)
 val use_file : formatter -> string -> bool
 val use_silently : formatter -> string -> bool
+val mod_use_file : formatter -> string -> bool
         (* Read and execute commands from a file.
            [use_file] prints the types and values of the results.
-           [use_silently] does not print them. *)
-val eval_path: Path.t -> Obj.t
+           [use_silently] does not print them.
+           [mod_use_file] wrap the file contents into a module. *)
+val eval_path: Env.t -> Path.t -> Obj.t
         (* Return the toplevel object referred to by the given path *)
 
 (* Printing of values *)
@@ -60,8 +65,19 @@ val eval_path: Path.t -> Obj.t
 val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit
 val print_untyped_exception: formatter -> Obj.t -> unit
 
+type ('a, 'b) gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
 val install_printer :
   Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit
+val install_generic_printer :
+  Path.t -> Path.t ->
+  (int -> (int -> Obj.t -> Outcometree.out_value,
+           Obj.t -> Outcometree.out_value) gen_printer) -> unit
+val install_generic_printer' :
+  Path.t -> Path.t -> (formatter -> Obj.t -> unit,
+                       formatter -> Obj.t -> unit) gen_printer -> unit
 val remove_printer : Path.t -> unit
 
 val max_printer_depth: int ref
@@ -95,7 +111,7 @@ val print_out_phrase :
 
 (* Hooks for external line editor *)
 
-val read_interactive_input : (string -> string -> int -> int * bool) ref
+val read_interactive_input : (string -> bytes -> int -> int * bool) ref
 
 (* Hooks for initialization *)
 
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index 51d1daac55..c44e173e2e 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -67,6 +67,7 @@ module Options = Main_args.Make_opttop_options (struct
     let dir = Misc.expand_directory Config.standard_library dir in
     include_dirs := dir :: !include_dirs
   let _init s = init_file := Some s
+  let _noinit = set noinit
   let _inline n = inline_threshold := n * 8
   let _labels = clear classic
   let _no_alias_deps = set transparent_modules
@@ -101,6 +102,7 @@ module Options = Main_args.Make_opttop_options (struct
   let _dcmm = set dump_cmm
   let _dsel = set dump_selection
   let _dcombine = set dump_combine
+  let _dcse = set dump_cse
   let _dlive () = dump_live := true; Printmach.print_live := true
   let _dspill = set dump_spill
   let _dsplit = set dump_split
@@ -111,6 +113,9 @@ module Options = Main_args.Make_opttop_options (struct
   let _dscheduling = set dump_scheduling
   let _dlinear = set dump_linear
   let _dstartup = set keep_startup_file
+  let _safe_string = clear unsafe_string
+  let _unsafe_string = set unsafe_string
+  let _open s = open_modules := s :: !open_modules
 
   let anonymous = file_argument
 end);;