Ajout de .ocamlinit et des scripts

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

5 files changed, 123 insertions, 81 deletions

diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 0bef3cb66..b243571b0 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -23,27 +23,6 @@ open Printval
 open Trace
 open Toploop
 
-(* Hooks for parsing functions *)
-
-let parse_toplevel_phrase = Toploop.parse_toplevel_phrase
-let parse_use_file = ref Parse.use_file
-let print_location = Location.print
-let print_warning = Location.print_warning
-let input_name = Location.input_name
-
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
-  let oldval = !r in
-  try
-    r := newval; 
-    let res = body() in
-    r := oldval;
-    res
-  with x ->
-    r := oldval;
-    raise x
-
 (* Return the value referred to by a path *)
 
 let rec eval_path = function
@@ -83,13 +62,8 @@ let load_compunit ic filename compunit =
   let code = Meta.static_alloc code_size in
   unsafe_really_input ic code 0 compunit.cu_codesize;
   String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
-  String.unsafe_set code (compunit.cu_codesize + 1) '\000';
-  String.unsafe_set code (compunit.cu_codesize + 2) '\000';
-  String.unsafe_set code (compunit.cu_codesize + 3) '\000';
-  String.unsafe_set code (compunit.cu_codesize + 4) '\001';
-  String.unsafe_set code (compunit.cu_codesize + 5) '\000';
-  String.unsafe_set code (compunit.cu_codesize + 6) '\000';
-  String.unsafe_set code (compunit.cu_codesize + 7) '\000';
+  String.unsafe_blit "\000\000\000\001\000\000\000" 0
+                     code (compunit.cu_codesize + 1) 7;
   let initial_symtable = Symtable.current_state() in
   Symtable.patch_object code compunit.cu_reloc;
   Symtable.update_global_table();
@@ -132,25 +106,7 @@ let _ = Hashtbl.add directive_table "load" (Directive_string dir_load)
 
 (* Load commands from a file *)
 
-let dir_use name =
-  try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
-    let lb = Lexing.from_channel ic in
-    protect Location.input_name filename (fun () ->
-      try
-        List.iter
-          (fun ph -> if execute_phrase ph then () else raise Exit)
-          (!parse_use_file lb)
-      with
-        Exit -> ()
-      | Sys.Break ->
-          print_string "Interrupted."; print_newline()
-      | x ->
-          Errors.report_error x);
-    close_in ic
-  with Not_found ->
-    print_string "Cannot find file "; print_string name; print_newline()
+let dir_use name = Toploop.use_file name; ()
 
 let _ = Hashtbl.add directive_table "use" (Directive_string dir_use)
 
diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
index f3bd62339..53b32fe76 100644
--- a/toplevel/topdirs.mli
+++ b/toplevel/topdirs.mli
@@ -24,8 +24,3 @@ val dir_trace : Longident.t -> unit
 val dir_untrace : Longident.t -> unit
 val dir_untrace_all : unit -> unit
 
-val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
-val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
-val print_location : Location.t -> unit
-val print_warning : Location.t -> string -> unit
-val input_name : string ref
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 298c989db..4947ac5d4 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -28,6 +28,14 @@ type directive_fun =
   | Directive_int of (int -> unit)
   | Directive_ident of (Longident.t -> unit)
 
+(* Hooks for parsing functions *)
+
+let parse_toplevel_phrase = ref Parse.toplevel_phrase
+let parse_use_file = ref Parse.use_file
+let print_location = Location.print
+let print_warning = Location.print_warning
+let input_name = Location.input_name
+
 (* Load in-core and execute a lambda term *)
 
 type evaluation_outcome = Result of Obj.t | Exception of exn
@@ -106,8 +114,11 @@ let print_exception_outcome = function
       print_string "Interrupted."; print_newline()
   | Out_of_memory ->
       Gc.full_major();
-      print_string "Out of memory during evaluation";
+      print_string "Out of memory during evaluation.";
       print_newline()
+  | Stack_overflow ->
+      print_string "Stack overflow during evaluation (looping recursion?).";
+      print_newline();
   | exn ->
       open_box 0;
       print_string "Uncaught exception: ";
@@ -123,7 +134,7 @@ let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
 
 let toplevel_env = ref Env.empty
 
-let execute_phrase phr =
+let execute_phrase print_outcome phr =
   match phr with
     Ptop_def sstr ->
       let (str, sg, newenv) = Typemod.type_structure !toplevel_env sstr in
@@ -131,20 +142,21 @@ let execute_phrase phr =
       let res = load_lambda lam in
       begin match res with
         Result v ->
-          begin match str with
-            [Tstr_eval exp] ->
-              open_box 0;
-              print_string "- : ";
-              Printtyp.type_scheme exp.exp_type;
-              print_space(); print_string "="; print_space();
-              print_value newenv v exp.exp_type;
-              close_box();
-              print_newline()
-          | _ ->
-              open_vbox 0;
-              print_items newenv sg;
-              close_box();
-              print_flush()
+          if print_outcome then begin
+            match str with
+              [Tstr_eval exp] ->
+                open_box 0;
+                print_string "- : ";
+                Printtyp.type_scheme exp.exp_type;
+                print_space(); print_string "="; print_space();
+                print_value newenv v exp.exp_type;
+                close_box();
+                print_newline()
+            | _ ->
+                open_vbox 0;
+                print_items newenv sg;
+                close_box();
+                print_flush()
           end;
           toplevel_env := newenv;
           true
@@ -168,7 +180,57 @@ let execute_phrase phr =
         print_string "'"; print_newline();
         false
 
-(* Reading function *)
+(* Temporary assignment to a reference *)
+
+let protect r newval body =
+  let oldval = !r in
+  try
+    r := newval; 
+    let res = body() in
+    r := oldval;
+    res
+  with x ->
+    r := oldval;
+    raise x
+
+(* Read and execute commands from a file *)
+
+let use_print_results = ref true
+
+let use_file name =
+  try
+    let filename = find_in_path !Config.load_path name in
+    let ic = open_in_bin filename in
+    let lb = Lexing.from_channel ic in
+    (* Skip initial #! line if any *)
+    let buffer = String.create 2 in
+    if input ic buffer 0 2 = 2 && buffer = "#!"
+    then begin input_line ic; () end
+    else seek_in ic 0;
+    let success =
+      protect Location.input_name filename (fun () ->
+        try
+          List.iter
+            (fun ph ->
+              if execute_phrase !use_print_results ph then () else raise Exit)
+            (!parse_use_file lb);
+          true
+        with
+          Exit -> false
+        | Sys.Break ->
+            print_string "Interrupted."; print_newline(); false
+        | x ->
+            Errors.report_error x; false) in
+    close_in ic;
+    success
+  with Not_found ->
+    print_string "Cannot find file "; print_string name; print_newline();
+    false
+
+let use_silently name =
+  protect use_print_results false (fun () -> use_file name)
+
+(* Reading function for interactive use *)
 
 let first_line = ref true
 let got_eof = ref false;;
@@ -203,15 +265,14 @@ let empty_lexbuf lb =
 let _ =
   Symtable.init_toplevel();
   Clflags.thread_safe := true;
-  Compile.init_path();
-  Sys.interactive := true
+  Compile.init_path()
 
-(* The loop *)
+(* The interactive loop *)
 
-let parse_toplevel_phrase = ref Parse.toplevel_phrase
 exception PPerror
 
 let loop() =
+  Sys.interactive := true;
   print_string "        Objective Caml version ";
   print_string Config.version;
   print_newline(); print_newline();
@@ -224,13 +285,14 @@ let loop() =
   Location.input_name := "";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
+  if Sys.file_exists ".ocamlinit" then begin use_silently ".ocamlinit"; () end;
   while true do
     try
       empty_lexbuf lb;
       Location.reset();
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
-      execute_phrase phr; ()
+      execute_phrase true phr; ()
     with
       End_of_file -> exit 0
     | Sys.Break ->
@@ -239,3 +301,12 @@ let loop() =
     | x ->
         Errors.report_error x
   done
+
+(* Execute a script *)
+
+let run_script name =
+  Compile.init_path();
+  toplevel_env := Compile.initial_env();
+  Format.set_formatter_out_channel stderr;
+  use_print_results := false;
+  use_file name
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 09bae1328..6a7cada13 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -15,6 +15,10 @@
 
 val loop: unit -> unit
 
+(* Read and execute a script from the given file *)
+
+val run_script: string -> bool (* true if successful, false if error *)
+
 (* Interface with toplevel directives *)
 
 type directive_fun =
@@ -25,11 +29,25 @@ type directive_fun =
 
 val directive_table: (string, directive_fun) Hashtbl.t
         (* Table of known directives, with their execution function *)
-val execute_phrase: Parsetree.toplevel_phrase -> bool
-        (* Execute the given toplevel phrase. Return [true] if the
-           phrase executed with no errors and [false] otherwise. *)
-val print_exception_outcome: exn -> unit
-        (* Print an exception resulting from the evaluation of user code. *)
 val toplevel_env: Env.t ref
         (* Typing environment for the toplevel *)
+val print_exception_outcome: exn -> unit
+        (* Print an exception resulting from the evaluation of user code. *)
+val execute_phrase: bool -> Parsetree.toplevel_phrase -> bool
+        (* Execute the given toplevel phrase. Return [true] if the
+           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 use_file: string -> bool
+val use_silently: 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. *)
+
+(* Hooks for an external parser *)
+
 val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
+val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
+val print_location : Location.t -> unit
+val print_warning : Location.t -> string -> unit
+val input_name : string ref
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 821ef309e..743bdfea6 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -15,6 +15,9 @@ open Clflags
 
 let usage = "Usage: ocaml <options>\noptions are:"
 
+let file_argument name =
+  exit (if Toploop.run_script name then 0 else 2)
+
 let main () =
   Arg.parse [
      "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
@@ -23,8 +26,7 @@ let main () =
      "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)";
      "-dlambda", Arg.Set dump_lambda, " (undocumented)";
      "-dinstr", Arg.Set dump_instr, " (undocumented)"
-    ] (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
-      usage;
+    ] file_argument usage;
   Toploop.loop()
 
 let _ = Printexc.catch main ()