Remove use of Obj.truncate from toplevel.

When running a script with "ocaml foo.ml", the toplevel needs to
run foo.ml with a different Sys.argv than the initial value, since
foo.ml must not see the initial "ocaml" argument.

Previously, this was done with Obj.truncate to shorten the Sys.argv
array. This patch changes it by introducing a primitive %sys_argv.
Uses of this primitive expand to a call to a new C primitive, which
returns the argv array (and can be modified by the toplevel).

bytecomp/translprim.ml

@@ -104,6 +104,9 @@ let get_used_primitives () =
 let gen_array_kind =
   if Config.flat_float_array then Pgenarray else Paddrarray
 
+let prim_sys_argv =
+  Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true
+
 let primitives_table =
   create_hashtable 57 [
     "%identity", Primitive (Pidentity, 1);
@@ -341,6 +344,7 @@ let primitives_table =
     "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1);
     "%int_as_pointer", Primitive (Pint_as_pointer, 1);
     "%opaque", Primitive (Popaque, 1);
+    "%sys_argv", External prim_sys_argv;
     "%send", Send;
     "%sendself", Send_self;
     "%sendcache", Send_cache;
@@ -647,6 +651,8 @@ let lambda_of_prim prim_name prim loc args arg_exps =
   match prim, args with
   | Primitive (prim, arity), args when arity = List.length args ->
       Lprim(prim, args, loc)
+  | External prim, args when prim = prim_sys_argv ->
+      Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc)
   | External prim, args ->
       Lprim(Pccall prim, args, loc)
   | Comparison(comp, knd), ([_;_] as args) ->

runtime/sys.c

@@ -371,22 +371,35 @@ CAMLprim value caml_sys_getenv(value var)
 }
 
 char_os * caml_exe_name;
-char_os ** caml_main_argv;
+static value main_argv;
 
 CAMLprim value caml_sys_get_argv(value unit)
 {
   CAMLparam0 ();   /* unit is unused */
-  CAMLlocal3 (exe_name, argv, res);
+  CAMLlocal2 (exe_name, res);
   exe_name = caml_copy_string_of_os(caml_exe_name);
-  argv =
-    caml_alloc_array((void *)caml_copy_string_of_os,
-                     (char const **) caml_main_argv);
   res = caml_alloc_small(2, 0);
   Field(res, 0) = exe_name;
-  Field(res, 1) = argv;
+  Field(res, 1) = main_argv;
   CAMLreturn(res);
 }
 
+CAMLprim value caml_sys_argv(value unit)
+{
+  return main_argv;
+}
+
+CAMLprim value caml_sys_modify_argv(value new_argv)
+{
+  caml_modify_generational_global_root(&main_argv, new_argv);
+  return Val_unit;
+}
+
+CAMLprim value caml_sys_executable_name(value unit)
+{
+  return caml_copy_string_of_os(caml_exe_name);
+}
+
 void caml_sys_init(char_os * exe_name, char_os **argv)
 {
 #ifdef _WIN32
@@ -398,7 +411,9 @@ void caml_sys_init(char_os * exe_name, char_os **argv)
 #endif
 #endif
   caml_exe_name = exe_name;
-  caml_main_argv = argv;
+  main_argv = caml_alloc_array((void *)caml_copy_string_of_os,
+			       (char const **) argv);
+  caml_register_generational_global_root(&main_argv);
 }
 
 #ifdef _WIN32

stdlib/sys.mli

@@ -20,7 +20,7 @@
   an error.
 *)
 
-val argv : string array
+external argv : string array = "%sys_argv"
 (** The command line arguments given to the process.
    The first element is the command name used to invoke the program.
    The following elements are the command-line arguments

stdlib/sys.mlp

@@ -25,7 +25,8 @@ type backend_type =
 (* System interface *)
 
 external get_config: unit -> string * int * bool = "caml_sys_get_config"
-external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external get_executable_name : unit -> string = "caml_sys_executable_name"
+external argv : string array = "%sys_argv"
 external big_endian : unit -> bool = "%big_endian"
 external word_size : unit -> int = "%word_size"
 external int_size : unit -> int = "%int_size"
@@ -35,7 +36,7 @@ external win32 : unit -> bool = "%ostype_win32"
 external cygwin : unit -> bool = "%ostype_cygwin"
 external get_backend_type : unit -> backend_type = "%backend_type"
 
-let (executable_name, argv) = get_argv()
+let executable_name = get_executable_name()
 let (os_type, _, _) = get_config()
 let backend_type = get_backend_type ()
 let big_endian = big_endian ()

testsuite/tests/tool-toplevel-invocation/print_args.ml

@@ -0,0 +1 @@
+Array.iter (fun x -> print_endline (Filename.basename x)) Sys.argv;;

testsuite/tests/tool-toplevel-invocation/print_args.reference

@@ -0,0 +1,3 @@
+print_args.ml
+foo
+bar

testsuite/tests/tool-toplevel-invocation/test.ml

@@ -40,6 +40,12 @@ compiler_reference = "${test_source_directory}/working_arg.txt.reference"
 compiler_output = "${test_build_directory}/working_arg.output"
 *** check-ocaml-output
 
+** ocaml
+flags = "${test_source_directory}/print_args.ml foo bar"
+compiler_reference = "${test_source_directory}/print_args.reference"
+compiler_output = "${test_build_directory}/print_args.output"
+*** check-ocaml-output
+
 *)
 
 printf "Test succeeds\n";;

toplevel/opttoploop.ml

@@ -607,21 +607,17 @@ let loop ppf =
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
-(* Execute a script.  If [name] is "", read the script from stdin. *)
+external caml_sys_modify_argv : string array -> unit =
+  "caml_sys_modify_argv"
 
-let override_sys_argv args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
+let override_sys_argv new_argv =
+  caml_sys_modify_argv new_argv;
   Arg.current := 0
 
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
 let run_script ppf name args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
-  Arg.current := 0;
+  override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) ();
                    (* Note: would use [Filename.abspath] here, if we had it. *)
   toplevel_env := Compmisc.initial_env();

toplevel/toploop.ml

@@ -565,15 +565,15 @@ let loop ppf =
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
-(* Execute a script.  If [name] is "", read the script from stdin. *)
+external caml_sys_modify_argv : string array -> unit =
+  "caml_sys_modify_argv"
 
-let override_sys_argv args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
+let override_sys_argv new_argv =
+  caml_sys_modify_argv new_argv;
   Arg.current := 0
 
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
 let run_script ppf name args =
   override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) ();