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 ...)
+
 ### 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,8 +156,7 @@ 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 file_argument ?(constructor=(fun x -> Toploop.File x)) name =
   let ppf = Format.err_formatter in
   if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
   then preload_objects := name :: !preload_objects
@@ -176,7 +175,9 @@ let file_argument name =
       in
       Compenv.readenv ppf Before_link;
       Compmisc.read_clflags_from_env ();
-      if prepare ppf && Toploop.run_script ppf name newargs
+      let usage =
+        constructor name in
+      if prepare ppf && Toploop.run_script ppf usage newargs
       then raise (Compenv.Exit_with_status 0)
       else raise (Compenv.Exit_with_status 2)
     end
@@ -190,10 +191,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 () = file_argument ~constructor:(fun _ -> 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 = file_argument ~constructor:(fun x -> Toploop.String x)  s
 end)
 
 let () =

toplevel/native/topmain.ml

@@ -48,7 +48,7 @@ let prepare ppf =
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false
 
-let file_argument name =
+let file_argument ?(constructor=(fun x -> Toploop.File x)) name =
   let ppf = Format.err_formatter in
   if Filename.check_suffix name ".cmxs"
     || Filename.check_suffix name ".cmx"
@@ -68,7 +68,8 @@ let file_argument name =
                               (Array.length !argv - !Arg.current)
       in
       Compmisc.read_clflags_from_env ();
-      if prepare ppf && Toploop.run_script ppf name newargs
+      if prepare ppf && Toploop.run_script ppf
+             (constructor name) newargs
       then raise (Compenv.Exit_with_status 0)
       else raise (Compenv.Exit_with_status 2)
     end
@@ -81,10 +82,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 () = file_argument ~constructor:(fun _ -> 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 = file_argument ~constructor:(fun x -> Toploop.String x) s
+
 end);;
 
 let () =

toplevel/topdirs.ml

@@ -143,9 +143,13 @@ 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 =
+  let usage = File name in
+  ignore (Toploop.use_file ppf usage)
 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 =
+  let usage = File name in
+  ignore (Toploop.mod_use_file ppf usage)
 
 let _ = add_directive "use" (Directive_string (dir_use std_out))
     {

toplevel/toploop.ml

@@ -18,11 +18,14 @@ include Topcommon
 include Topeval
 
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
+type input_type =
+  | 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 use_channel ppf ~wrap_in_module lb name filename =
   Warnings.reset_fatal ();
   Location.init lb filename;
   (* Skip initial #! line if any *)
@@ -60,21 +63,28 @@ 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_channel 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_file ppf ~wrap_in_module usage =
+  match usage with
+  | Stdin ->
+    let lexbuf = Lexing.from_channel stdin in
+    use_channel ppf ~wrap_in_module lexbuf "" "(stdin)"
+  | String value ->
+    let lexbuf = Lexing.from_string value in
+    use_channel ppf ~wrap_in_module lexbuf "" "(stdin)"
+  | 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_channel ppf ~wrap_in_module lexbuf name filename)
     | exception Not_found ->
       fprintf ppf "Cannot find file %s.@." name;
       false
@@ -95,7 +105,11 @@ let load_file = load_file false
 
 let run_script ppf name args =
   override_sys_argv args;
-  Compmisc.init_path ~dir:(Filename.dirname name) ();
+  let filename =
+    match name with
+    | File name -> 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)
+    | 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,6 +15,11 @@
 
 open Format
 
+(* type of toplevel usages *)
+type input_type =
+  | 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.) *)
@@ -31,7 +36,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_type -> string array -> bool
         (* true if successful, false if error *)
 
 (* Interface with toplevel directives *)
@@ -82,10 +87,10 @@ 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_file : formatter -> input_type -> 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_type -> bool
+val mod_use_file : formatter -> input_type -> bool
         (* Read and execute commands from a file.
            [use_file] prints the types and values of the results.
            [use_silently] does not print them.