added -e eval option for runtop and natruntop

Changes

@@ -249,6 +249,10 @@ Working version
   the reference manual.
   (John Whitington, review by David Allsopp)
 
+- #10438: add a new toplevel cli argument `-e <script>` to
+  run script passed to the toplevel.
+  (Pavlo Khrystenko, review by Gabriel Scherer)
+
 ### Manual and documentation:
 
 - #10247: Add initial tranche of examples to reference manual.

driver/main_args.ml

@@ -94,6 +94,11 @@ let mk_dllpath f =
   "<dir>  Add <dir> to the run-time search path for shared libraries"
 ;;
 
+let mk_eval f =
+  "-e", Arg.String f,
+  "<script>  Evaluate given script"
+;;
+
 let mk_function_sections f =
   if Config.function_sections then
     "-function-sections",  Arg.Unit f,
@@ -1015,6 +1020,7 @@ module type Toplevel_options = sig
   val _args0 : string -> string array
   val _color : string -> unit
   val _error_style : string -> unit
+  val _eval: string -> unit
 end
 ;;
 
@@ -1310,6 +1316,7 @@ struct
 
     mk_args F._args;
     mk_args0 F._args0;
+    mk_eval F._eval;
   ]
 end;;
 
@@ -1566,6 +1573,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dinterval F._dinterval;
     mk_dstartup F._dstartup;
     mk_dump_pass F._dump_pass;
+    mk_eval F._eval;
   ]
 end;;
 
@@ -1905,6 +1913,7 @@ module Default = struct
     let _stdin () = (* placeholder: file_argument ""*) ()
     let _version () = print_version ()
     let _vnum () = print_version_num ()
+    let _eval (_:string) = ()
   end
 
   module Topmain = struct

driver/main_args.mli

@@ -137,6 +137,7 @@ module type Toplevel_options = sig
   val _args0 : string -> string array
   val _color : string -> unit
   val _error_style : string -> unit
+  val _eval: string -> unit
 end
 ;;
 

toplevel/byte/topmain.ml

@@ -156,19 +156,20 @@ let prepare ppf =
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false
 
-(* If [name] is "", then the "file" is stdin treated as a script file. *)
-let file_argument name =
+let input_argument name =
+  let filename = Toploop.filename_of_input name in
   let ppf = Format.err_formatter in
-  if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
-  then preload_objects := name :: !preload_objects
+  if Filename.check_suffix filename ".cmo"
+          || Filename.check_suffix filename ".cma"
+  then preload_objects := filename :: !preload_objects
   else if is_expanded !current then begin
     (* Script files are not allowed in expand options because otherwise the
        check in override arguments may fail since the new argv can be larger
        than the original argv.
     *)
     Printf.eprintf "For implementation reasons, the toplevel does not support\
    \ having script files (here %S) inside expanded arguments passed through the\
-   \ -args{,0} command-line option.\n" name;
+   \ -args{,0} command-line option.\n" filename;
     raise (Compenv.Exit_with_status 2)
   end else begin
       let newargs = Array.sub !argv !current
@@ -181,6 +182,7 @@ let file_argument name =
       else raise (Compenv.Exit_with_status 2)
     end
 
+let file_argument x = input_argument (Toploop.File x)
 
 let wrap_expand f s =
   let start = !current in
@@ -190,10 +192,11 @@ let wrap_expand f s =
 
 module Options = Main_args.Make_bytetop_options (struct
     include Main_args.Default.Topmain
-    let _stdin () = file_argument ""
+    let _stdin () = input_argument Toploop.Stdin
     let _args = wrap_expand Arg.read_arg
     let _args0 = wrap_expand Arg.read_arg0
     let anonymous s = file_argument s
+    let _eval s = input_argument (Toploop.String  s)
 end)
 
 let () =

toplevel/native/topmain.ml

@@ -48,20 +48,21 @@ let prepare ppf =
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false
 
-let file_argument name =
+let input_argument name =
+  let filename = Toploop.filename_of_input name in
   let ppf = Format.err_formatter in
-  if Filename.check_suffix name ".cmxs"
-    || Filename.check_suffix name ".cmx"
-    || Filename.check_suffix name ".cmxa"
-  then preload_objects := name :: !preload_objects
+  if Filename.check_suffix filename ".cmxs"
+    || Filename.check_suffix filename ".cmx"
+    || Filename.check_suffix filename ".cmxa"
+  then preload_objects := filename :: !preload_objects
   else if is_expanded !current then begin
     (* Script files are not allowed in expand options because otherwise the
        check in override arguments may fail since the new argv can be larger
        than the original argv.
     *)
     Printf.eprintf "For implementation reasons, the toplevel does not support\
     \ having script files (here %S) inside expanded arguments passed through\
-    \ the -args{,0} command-line option.\n" name;
+    \ the -args{,0} command-line option.\n" filename;
     raise (Compenv.Exit_with_status 2)
   end else begin
     let newargs = Array.sub !argv !Arg.current
@@ -73,6 +74,8 @@ let file_argument name =
       else raise (Compenv.Exit_with_status 2)
     end
 
+let file_argument x = input_argument (Toploop.File x)
+
 let wrap_expand f s =
   let start = !current in
   let arr = f s in
@@ -81,10 +84,12 @@ let wrap_expand f s =
 
 module Options = Main_args.Make_opttop_options (struct
     include Main_args.Default.Opttopmain
-    let _stdin () = file_argument ""
+    let _stdin () = input_argument Toploop.Stdin
     let _args = wrap_expand Arg.read_arg
     let _args0 = wrap_expand Arg.read_arg0
     let anonymous s = file_argument s
+    let _eval s = input_argument (Toploop.String s)
+
 end);;
 
 let () =

toplevel/topdirs.ml

@@ -143,9 +143,11 @@ let load_file = Topeval.load_file false
 
 (* Load commands from a file *)
 
-let dir_use ppf name = ignore(Toploop.use_file ppf name)
+let dir_use ppf name =
+  ignore (Toploop.use_input ppf (Toploop.File name))
 let dir_use_output ppf name = ignore(Toploop.use_output ppf name)
-let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
+let dir_mod_use ppf name =
+  ignore (Toploop.mod_use_input ppf (Toploop.File name))
 
 let _ = add_directive "use" (Directive_string (dir_use std_out))
     {

toplevel/toploop.ml

@@ -17,12 +17,18 @@ open Format
 include Topcommon
 include Topeval
 
-(* Read and execute commands from a file, or from stdin if [name] is "". *)
+type input =
+  | Stdin
+  | File of string
+  | String of string
 
 let use_print_results = ref true
 
-let use_channel ppf ~wrap_in_module ic name filename =
-  let lb = Lexing.from_channel ic in
+let filename_of_input = function
+  | File name -> name
+  | Stdin | String _ -> ""
+
+let use_lexbuf ppf ~wrap_in_module lb name filename =
   Warnings.reset_fatal ();
   Location.init lb filename;
   (* Skip initial #! line if any *)
@@ -60,42 +66,50 @@ let use_output ppf command =
          let ic = open_in_bin fn in
          Misc.try_finally ~always:(fun () -> close_in ic)
            (fun () ->
-              use_channel ppf ~wrap_in_module:false ic "" "(command-output)")
+            let lexbuf = (Lexing.from_channel ic) in
+            use_lexbuf ppf ~wrap_in_module:false lexbuf "" "(command-output)")
        | n ->
          fprintf ppf "Command exited with code %d.@." n;
          false)
 
-let use_file ppf ~wrap_in_module name =
-  match name with
-  | "" ->
-    use_channel ppf ~wrap_in_module stdin name "(stdin)"
-  | _ ->
+let use_input ppf ~wrap_in_module input =
+  match input with
+  | Stdin ->
+    let lexbuf = Lexing.from_channel stdin in
+    use_lexbuf ppf ~wrap_in_module lexbuf "" "(stdin)"
+  | String value ->
+    let lexbuf = Lexing.from_string value in
+    use_lexbuf ppf ~wrap_in_module lexbuf "" "(command-line input)"
+  | File name ->
     match Load_path.find name with
     | filename ->
       let ic = open_in_bin filename in
       Misc.try_finally ~always:(fun () -> close_in ic)
-        (fun () -> use_channel ppf ~wrap_in_module ic name filename)
+        (fun () ->
+          let lexbuf = Lexing.from_channel ic in
+          use_lexbuf ppf ~wrap_in_module lexbuf name filename)
     | exception Not_found ->
       fprintf ppf "Cannot find file %s.@." name;
       false
 
-let mod_use_file ppf name =
-  use_file ppf ~wrap_in_module:true name
-let use_file ppf name =
-  use_file ppf ~wrap_in_module:false name
+let mod_use_input ppf name =
+  use_input ppf ~wrap_in_module:true name
+let use_input ppf name =
+  use_input ppf ~wrap_in_module:false name
 
 let use_silently ppf name =
   Misc.protect_refs
     [ R (use_print_results, false) ]
-    (fun () -> use_file ppf name)
+    (fun () -> use_input ppf name)
 
 let load_file = load_file false
 
 (* 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) ();
+  let filename = filename_of_input name in
+  Compmisc.init_path ~dir:(Filename.dirname filename) ();
                    (* Note: would use [Filename.abspath] here, if we had it. *)
   begin
     try toplevel_env := Compmisc.initial_env()
@@ -105,10 +119,13 @@ let run_script ppf name args =
   Sys.interactive := false;
   run_hooks After_setup;
   let explicit_name =
+    match name with
+    | File name as filename  -> (
     (* Prevent use_silently from searching in the path. *)
     if name <> "" && Filename.is_implicit name
-    then Filename.concat Filename.current_dir_name name
-    else name
+    then File (Filename.concat Filename.current_dir_name name)
+    else filename)
+    | (Stdin | String _) as x -> x
   in
   use_silently ppf explicit_name
 
@@ -152,12 +169,13 @@ let find_ocamlinit () =
 let load_ocamlinit ppf =
   if !Clflags.noinit then ()
   else match !Clflags.init_file with
-  | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
-              else fprintf ppf "Init file not found: \"%s\".@." f
+  | Some f ->
+    if Sys.file_exists f then ignore (use_silently ppf (File f) )
+    else fprintf ppf "Init file not found: \"%s\".@." f
   | None ->
       match find_ocamlinit () with
       | None -> ()
-      | Some file -> ignore (use_silently ppf file)
+      | Some file -> ignore (use_silently ppf (File file))
 
 (* The interactive loop *)
 

toplevel/toploop.mli

@@ -15,12 +15,21 @@
 
 open Format
 
+(* type of toplevel inputs *)
+type input =
+  | Stdin
+  | File of string
+  | String of string
+
 (* Accessors for the table of toplevel value bindings.  These functions
    must appear as first and second exported functions in this module.
    (See module Translmod.) *)
 val getvalue : string -> Obj.t
 val setvalue : string -> Obj.t -> unit
 
+
+val filename_of_input: input -> string
+
 (* Set the load paths, before running anything *)
 
 val set_paths : unit -> unit
@@ -31,7 +40,7 @@ val loop : formatter -> unit
 
 (* Read and execute a script from the given file *)
 
-val run_script : formatter -> string -> string array -> bool
+val run_script : formatter -> input -> string array -> bool
         (* true if successful, false if error *)
 
 (* Interface with toplevel directives *)
@@ -82,14 +91,14 @@ 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_input : formatter -> input -> bool
 val use_output : formatter -> string -> bool
-val use_silently : formatter -> string -> bool
-val mod_use_file : formatter -> string -> bool
+val use_silently : formatter -> input -> bool
+val mod_use_input : formatter -> input -> bool
         (* Read and execute commands from a file.
-           [use_file] prints the types and values of the results.
+           [use_input] prints the types and values of the results.
            [use_silently] does not print them.
-           [mod_use_file] wrap the file contents into a module. *)
+           [mod_use_input] wrap the file contents into a module. *)
 val eval_module_path: Env.t -> Path.t -> Obj.t
 val eval_value_path: Env.t -> Path.t -> Obj.t
 val eval_extension_path: Env.t -> Path.t -> Obj.t