Factorise toplevel phrase evaluation between byte and native (ocaml#1…

…0187)

It's actually even simpler this way!

Note that one small change in the interface was required: the function
Toploop.eval_address could raise a `Symtable.Error` for undefined globals. Since
that wouldn't make sense for the native toplevel, we define a specific exception
for this purpose. Hopefully no one was relying on this at so low-level.

.depend

@@ -6120,7 +6120,6 @@ toplevel/genprintval.cmi : \
     typing/outcometree.cmi \
     typing/env.cmi
 toplevel/topcommon.cmo : \
-    typing/types.cmi \
     parsing/printast.cmi \
     typing/predef.cmi \
     parsing/pprintast.cmi \
@@ -6135,6 +6134,7 @@ toplevel/topcommon.cmo : \
     parsing/location.cmi \
     utils/load_path.cmi \
     parsing/lexer.cmi \
+    typing/ident.cmi \
     toplevel/genprintval.cmi \
     typing/env.cmi \
     bytecomp/dll.cmi \
@@ -6145,7 +6145,6 @@ toplevel/topcommon.cmo : \
     parsing/ast_helper.cmi \
     toplevel/topcommon.cmi
 toplevel/topcommon.cmx : \
-    typing/types.cmx \
     parsing/printast.cmx \
     typing/predef.cmx \
     parsing/pprintast.cmx \
@@ -6160,6 +6159,7 @@ toplevel/topcommon.cmx : \
     parsing/location.cmx \
     utils/load_path.cmx \
     parsing/lexer.cmx \
+    typing/ident.cmx \
     toplevel/genprintval.cmx \
     typing/env.cmx \
     bytecomp/dll.cmx \
@@ -6177,6 +6177,7 @@ toplevel/topcommon.cmi : \
     typing/outcometree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    typing/ident.cmi \
     toplevel/genprintval.cmi \
     typing/env.cmi
 toplevel/topdirs.cmo : \
@@ -6231,9 +6232,7 @@ toplevel/topdirs.cmi : \
     parsing/longident.cmi
 toplevel/topeval.cmi : \
     toplevel/topcommon.cmi \
-    typing/path.cmi \
-    parsing/parsetree.cmi \
-    typing/env.cmi
+    parsing/parsetree.cmi
 toplevel/toploop.cmo : \
     utils/warnings.cmi \
     typing/typetexp.cmi \
@@ -6301,7 +6300,6 @@ toplevel/byte/topeval.cmo : \
     bytecomp/printinstr.cmi \
     typing/predef.cmi \
     typing/persistent_env.cmi \
-    typing/path.cmi \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
     bytecomp/opcodes.cmi \
@@ -6311,7 +6309,6 @@ toplevel/byte/topeval.cmo : \
     utils/load_path.cmi \
     typing/includemod.cmi \
     typing/ident.cmi \
-    toplevel/genprintval.cmi \
     typing/env.cmi \
     bytecomp/emitcode.cmi \
     bytecomp/dll.cmi \
@@ -6338,7 +6335,6 @@ toplevel/byte/topeval.cmx : \
     bytecomp/printinstr.cmx \
     typing/predef.cmx \
     typing/persistent_env.cmx \
-    typing/path.cmx \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
     bytecomp/opcodes.cmx \
@@ -6348,7 +6344,6 @@ toplevel/byte/topeval.cmx : \
     utils/load_path.cmx \
     typing/includemod.cmx \
     typing/ident.cmx \
-    toplevel/genprintval.cmx \
     typing/env.cmx \
     bytecomp/emitcode.cmx \
     bytecomp/dll.cmx \
@@ -6361,9 +6356,7 @@ toplevel/byte/topeval.cmx : \
     toplevel/byte/topeval.cmi
 toplevel/byte/topeval.cmi : \
     toplevel/topcommon.cmi \
-    typing/path.cmi \
-    parsing/parsetree.cmi \
-    typing/env.cmi
+    parsing/parsetree.cmi
 toplevel/byte/topmain.cmo : \
     toplevel/byte/trace.cmi \
     toplevel/toploop.cmi \
@@ -6444,7 +6437,6 @@ toplevel/native/topeval.cmo : \
     typing/printtyp.cmi \
     lambda/printlambda.cmi \
     typing/predef.cmi \
-    typing/path.cmi \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
     utils/misc.cmi \
@@ -6454,7 +6446,6 @@ toplevel/native/topeval.cmo : \
     typing/includemod.cmi \
     middle_end/flambda/import_approx.cmi \
     typing/ident.cmi \
-    toplevel/genprintval.cmi \
     middle_end/flambda/flambda_middle_end.cmi \
     typing/env.cmi \
     utils/config.cmi \
@@ -6483,7 +6474,6 @@ toplevel/native/topeval.cmx : \
     typing/printtyp.cmx \
     lambda/printlambda.cmx \
     typing/predef.cmx \
-    typing/path.cmx \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
     utils/misc.cmx \
@@ -6493,7 +6483,6 @@ toplevel/native/topeval.cmx : \
     typing/includemod.cmx \
     middle_end/flambda/import_approx.cmx \
     typing/ident.cmx \
-    toplevel/genprintval.cmx \
     middle_end/flambda/flambda_middle_end.cmx \
     typing/env.cmx \
     utils/config.cmx \
@@ -6510,9 +6499,7 @@ toplevel/native/topeval.cmx : \
     toplevel/native/topeval.cmi
 toplevel/native/topeval.cmi : \
     toplevel/topcommon.cmi \
-    typing/path.cmi \
-    parsing/parsetree.cmi \
-    typing/env.cmi
+    parsing/parsetree.cmi
 toplevel/native/topmain.cmo : \
     toplevel/toploop.cmi \
     toplevel/native/topeval.cmi \

Changes

@@ -143,7 +143,7 @@ Working version
   to the implementation and the coercion.
   (Leandro Ostera, review by Gabriel Scherer and Thomas Refis)
 
-* #10061, #10078: remove library `ocamlopttoplevel`, remove modules
+* #10061, #10078, #10187: remove library `ocamlopttoplevel`, remove modules
   `Opttoploop`, `Opttopstart`, which are replaced by `Toploop` and `Topstart` in
   library `ocamltoplevel`, made available in native code.
 

testsuite/tests/tool-toplevel/pr6468.compilers.reference

@@ -10,5 +10,5 @@ Raised at f in file "//toplevel//", line 2, characters 11-26
 Called from g in file "//toplevel//", line 1, characters 11-15
 Called from Stdlib__Fun.protect in file "fun.ml", line 33, characters 8-15
 Re-raised at Stdlib__Fun.protect in file "fun.ml", line 38, characters 6-52
-Called from Topeval.load_lambda in file "toplevel/byte/topeval.ml", line 114, characters 4-150
+Called from Topeval.load_lambda in file "toplevel/byte/topeval.ml", line 89, characters 4-150
 

toplevel/byte/topeval.ml

@@ -39,52 +39,27 @@ let setvalue name v =
 
 let implementation_label = ""
 
-(* Return the value referred to by a path *)
-
-let rec eval_address = function
-  | Env.Aident id ->
-      if Ident.persistent id || Ident.global id then
-        Symtable.get_global_value id
-      else begin
-        let name = Translmod.toplevel_name id in
-        try
-          String.Map.find name !toplevel_value_bindings
-        with Not_found ->
-          raise (Symtable.Error(Symtable.Undefined_global name))
-      end
-  | Env.Adot(p, pos) ->
-      Obj.field (eval_address p) pos
-
-let eval_path find env path =
-  match find path env with
-  | addr -> eval_address addr
-  | exception Not_found ->
-      fatal_error ("Cannot find address for: " ^ (Path.name path))
-
-let eval_module_path env path =
-  eval_path Env.find_module_address env path
-
-let eval_value_path env path =
-  eval_path Env.find_value_address env path
-
-let eval_extension_path env path =
-  eval_path Env.find_constructor_address env path
+(* To print values *)
 
-let eval_class_path env path =
-  eval_path Env.find_class_address env path
+module EvalBase = struct
 
-(* To print values *)
+  let eval_ident id =
+    if Ident.persistent id || Ident.global id then begin
+      try
+        Symtable.get_global_value id
+      with Symtable.Error (Undefined_global name) ->
+        raise (Undefined_global name)
+    end else begin
+      let name = Translmod.toplevel_name id in
+      try
+        String.Map.find name !toplevel_value_bindings
+      with Not_found ->
+        raise (Undefined_global name)
+    end
 
-module EvalPath = struct
-  type valu = Obj.t
-  exception Error
-  let eval_address addr =
-    try eval_address addr with Symtable.Error _ -> raise Error
-  let same_value v1 v2 = (v1 == v2)
 end
 
-include Topcommon.MakePrinter(Genprintval.Make(Obj)(EvalPath))
-
+include Topcommon.MakeEvalPrinter(EvalBase)
 
 (* Load in-core and execute a lambda term *)
 

toplevel/native/topeval.ml

@@ -91,43 +91,19 @@ let toplevel_value id =
 
 (* Return the value referred to by a path *)
 
-let rec eval_address = function
-  | Env.Aident id ->
+module EvalBase = struct
+
+  let eval_ident id =
+    try
       if Ident.persistent id || Ident.global id
       then global_symbol id
       else toplevel_value id
-  | Env.Adot(a, pos) ->
-      Obj.field (eval_address a) pos
-
-let eval_path find env path =
-  match find path env with
-  | addr -> eval_address addr
-  | exception Not_found ->
-      fatal_error ("Cannot find address for: " ^ (Path.name path))
-
-let eval_module_path env path =
-  eval_path Env.find_module_address env path
-
-let eval_value_path env path =
-  eval_path Env.find_value_address env path
-
-let eval_extension_path env path =
-  eval_path Env.find_constructor_address env path
-
-let eval_class_path env path =
-  eval_path Env.find_class_address env path
-
-(* To print values *)
+    with _ ->
+      raise (Undefined_global (Ident.name id))
 
-module EvalPath = struct
-  type valu = Obj.t
-  exception Error
-  let eval_address addr =
-    try eval_address addr with _ -> raise Error
-  let same_value v1 v2 = (v1 == v2)
 end
 
-include Topcommon.MakePrinter(Genprintval.Make(Obj)(EvalPath))
+include Topcommon.MakeEvalPrinter(EvalBase)
 
 (* Load in-core and execute a lambda term *)
 

toplevel/topcommon.ml

@@ -71,43 +71,52 @@ let toplevel_env = ref Env.empty
 
 let backtrace = ref None
 
-(* Generic printer *)
+(* Generic evaluator and printer *)
 
-module type PRINTER = sig
+exception Undefined_global of string
 
-  module Printer: Genprintval.S with type t = Obj.t
+module type EVAL_BASE = sig
 
-  val print_value: Env.t -> Printer.t -> formatter -> Types.type_expr -> unit
-  val print_untyped_exception: formatter -> Printer.t -> unit
+  (* Return the value referred to by a base ident.
+     @raise [Undefined_global] if not found *)
+  val eval_ident: Ident.t -> Obj.t
 
-  val print_exception_outcome : formatter -> exn -> unit
+end
 
-  val outval_of_value:
-    Env.t -> Printer.t -> Types.type_expr -> Outcometree.out_value
+module MakeEvalPrinter (E: EVAL_BASE) = struct
 
-  type ('a, 'b) gen_printer =
-    | Zero of 'b
-    | Succ of ('a -> ('a, 'b) gen_printer)
+  let rec eval_address = function
+    | Env.Aident id -> E.eval_ident id
+    | Env.Adot(p, pos) -> Obj.field (eval_address p) pos
 
-  val install_printer :
-    Path.t -> Types.type_expr -> (formatter -> Printer.t -> unit) -> unit
-  val install_generic_printer :
-    Path.t -> Path.t ->
-    (int -> (int -> Printer.t -> Outcometree.out_value,
-            Printer.t-> Outcometree.out_value) gen_printer) -> unit
-  val install_generic_printer' :
-    Path.t -> Path.t -> (formatter -> Printer.t -> unit,
-                         formatter -> Printer.t -> unit) gen_printer -> unit
-  val remove_printer : Path.t -> unit
+  let eval_path find env path =
+    match find path env with
+    | addr -> eval_address addr
+    | exception Not_found ->
+        Misc.fatal_error ("Cannot find address for: " ^ (Path.name path))
 
-end
+  let eval_module_path env path =
+    eval_path Env.find_module_address env path
+
+  let eval_value_path env path =
+    eval_path Env.find_value_address env path
+
+  let eval_extension_path env path =
+    eval_path Env.find_constructor_address env path
+
+  let eval_class_path env path =
+    eval_path Env.find_class_address env path
 
-module MakePrinter
-    (Printer: Genprintval.S with type t = Obj.t)
-  : PRINTER
-= struct
 
-  module Printer = Printer
+  module Printer = Genprintval.Make(Obj)(struct
+      type valu = Obj.t
+      exception Error
+      let eval_address addr =
+        try eval_address addr
+        with Undefined_global _ ->
+          raise Error
+      let same_value v1 v2 = (v1 == v2)
+    end)
 
   let print_untyped_exception ppf obj =
     !print_out_value ppf (Printer.outval_of_untyped_exception obj)

toplevel/topcommon.mli

@@ -66,7 +66,28 @@ val print_out_signature :
 val print_out_phrase :
   (formatter -> Outcometree.out_phrase -> unit) ref
 
-module type PRINTER = sig
+
+exception Undefined_global of string
+
+module type EVAL_BASE = sig
+
+  (* Return the value referred to by a base ident
+     @raise [Undefined_global] if not found *)
+  val eval_ident: Ident.t -> Obj.t
+
+end
+
+
+module MakeEvalPrinter (_ : EVAL_BASE) : sig
+
+  val eval_address: Env.address -> Obj.t
+    (* Used for printers *)
+
+  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
+  val eval_class_path: Env.t -> Path.t -> Obj.t
+    (* Return the toplevel object referred to by the given path *)
 
   module Printer: Genprintval.S with type t = Obj.t
 
@@ -97,8 +118,6 @@ module type PRINTER = sig
 
 end
 
-module MakePrinter (P : Genprintval.S with type t = Obj.t):
-  PRINTER with module Printer = P
 
 (* Interface with toplevel directives *)