From 548bc0da64a80e914ea864aa790c332ca6554b8b Mon Sep 17 00:00:00 2001 From: cqc Date: Thu, 5 Aug 2021 23:23:09 -0500 Subject: [PATCH] that was quite the breakup --- bin/dune | 22 +- bin/init.ml | 6 + bin/main.ml | 116 +-- bin/topinf.ml | 2427 ++++++++++++++++++++++++++++++++++++++++++++++++ bin/topinf.mli | 12 + 5 files changed, 2468 insertions(+), 115 deletions(-) create mode 100644 bin/init.ml create mode 100644 bin/topinf.ml create mode 100644 bin/topinf.mli diff --git a/bin/dune b/bin/dune index 5c039b9..559b865 100644 --- a/bin/dune +++ b/bin/dune @@ -3,12 +3,28 @@ (modes byte) (modules main) (link_flags (-linkall)) + (libraries topinf + tsdl + tgls.tgles2 + wall + zed + irmin-unix + ocaml-compiler-libs.common + ocaml-compiler-libs.bytecomp + ocaml-compiler-libs.toplevel + findlib)) + +(library + (name topinf) + (modes byte) + (modules topinf) (libraries tsdl tgls.tgles2 wall zed irmin-unix - compiler-libs.toplevel - findlib_top ocaml-compiler-libs.common - ocaml-compiler-libs.toplevel)) + ocaml-compiler-libs.bytecomp + ocaml-compiler-libs.toplevel + findlib)) + diff --git a/bin/init.ml b/bin/init.ml new file mode 100644 index 0000000..d13c504 --- /dev/null +++ b/bin/init.ml @@ -0,0 +1,6 @@ +#directory "";; + +let x = 1.0;; + +assert (x = 1.0) + diff --git a/bin/main.ml b/bin/main.ml index 682d9c4..71cdfb0 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,118 +1,9 @@ -[@@@ocaml.warning "-6-9-26-27"] +[@@@ocaml.warning "-6-9-26-27-32-34"] open Lwt.Infix module F = Fmt module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String) -module Topmain = struct - open Ocaml_common - open Ocaml_toplevel - module Compenv = Ocaml_common.Compenv - - let read_interactive_input = ref (fun _ _ -> 0) - - exception PPerror - - (* Phase buffer that stores the last toplevel phrase (see [Location.input_phrase_buffer]). *) - let phrase_buffer = Buffer.create 1024 - - type evalenv = Format.formatter -> string -> unit - - let eval lb ppf (text : string) = - F.epr "Topmain.eval: \n"; - (read_interactive_input := - fun buffer _ -> - Bytes.blit_string text 0 buffer 0 (String.length text); - Buffer.add_string phrase_buffer text; - (* Also populate the phrase buffer as new characters are added. *) - String.length text); - let snap = Btype.snapshot () in - try - F.epr "Topmain.eval: 1 reset@."; - Buffer.reset phrase_buffer; - (* Reset the phrase buffer, then flush the lexing buffer. *) - Lexing.flush_input lb; - (* calls read_interactive_input to fill buffer again *) - Location.reset (); - Warnings.reset_fatal (); - F.epr "Topmain.eval: 2 Toploop.parse_toplevel_phrase@."; - let phr = - try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror - in - F.epr "Topmain.eval: 3 Toploop.preprocess_phrase@."; - let phr = Toploop.preprocess_phrase ppf phr in - F.epr "Topmain.eval: 4 Env.reset_cache_toplevel@."; - Env.reset_cache_toplevel (); - F.epr "Topmain.eval: 5 Toploop.execute_phrase=%b@." - (Toploop.execute_phrase true ppf phr); - F.epr "Topmain.eval: 6 handle exceptions@." - with - | End_of_file -> - F.epr "Topmain.eval End_of_file exception\n"; - Btype.backtrack snap - | Sys.Break -> - F.epr "Topmain.eval Sys.Break exception\n"; - F.pf ppf "Interrupted.@."; - Btype.backtrack snap - | PPerror -> - F.epr "Topmain.eval PPerror exception\n"; - () - | x -> - F.epr "Topmain.eval unknown exception\n"; - Location.report_exception ppf x; - Btype.backtrack snap - - let preload_objects = ref [ (*"komm.cma"*) ] - - let init ppf = - F.epr "Topmain.init: \n"; - Clflags.include_dirs := - List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs; - (* Topdirs.dir_directory ((Sys.getcwd ()) ^ "/topfind");*) - let extra_paths = - match Sys.getenv "OCAML_TOPLEVEL_PATH" with - | exception Not_found -> [] - | s -> Misc.split_path_contents s - in - Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs; - Compenv.readenv ppf Before_args; - Compenv.readenv ppf Before_link; - Compmisc.read_clflags_from_env (); - Toploop.set_paths (); - (try - F.epr "Load_path.get_paths: @."; - List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ()); - let res = - List.for_all - (fun name -> - F.epr "Topdirs.load_file: name=%s@." name; - Topdirs.load_file ppf name) - (List.rev !preload_objects @ !Compenv.first_objfiles) - in - Toploop.run_hooks Toploop.Startup; - if not res then raise Exit - with Exit as x -> - Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n" - (Printexc.to_string x)); - Compmisc.init_path (); - Clflags.debug := true; - Location.formatter_for_warnings := ppf; - if not !Clflags.noversion then - F.pf ppf "OCaml version %s@.@." Config.version; - (try Toploop.initialize_toplevel_env () - with (Env.Error _ | Typetexp.Error _) as exn -> - Location.report_exception ppf exn; - raise Exit); - let lb = Lexing.from_function (fun b l -> !read_interactive_input b l) in - Location.init lb "//toplevel//"; - Location.input_name := "//toplevel//"; - Location.input_lexbuf := Some lb; - Location.input_phrase_buffer := Some phrase_buffer; - Sys.catch_break true; - Toploop.run_hooks Toploop.After_setup; - eval lb -end - module Display = struct open Tgles2 open Tsdl @@ -659,7 +550,7 @@ let draw_storeview (r : storeview) height (s : Display.state) = type top = { te : textedit; res : Format.symbolic_output_buffer; - mutable eval : Topmain.evalenv option; + mutable eval : Topinf.evalenv option; path : string list; storeview : storeview; } @@ -708,7 +599,7 @@ let draw_top (t : top) height (s : Display.state) = match t.eval with | None -> let e = - Topmain.init (Format.formatter_of_symbolic_output_buffer t.res) + Topinf.init (Format.formatter_of_symbolic_output_buffer t.res) in t.eval <- Some e; e @@ -720,6 +611,7 @@ let draw_top (t : top) height (s : Display.state) = F.epr "draw_top: previous t.res=@."; format_symbolic_output_buffer F.stderr (Format.flush_symbolic_output_buffer t.res); + Topinf.print_toplevel_value_bindings (); (* HACK overwriting stdout formatter because fucking ocaml/toplevel/topdirs.ml hardcodes it *) Format.pp_set_formatter_out_functions Format.std_formatter (out_funs_of_sob t.res); diff --git a/bin/topinf.ml b/bin/topinf.ml new file mode 100644 index 0000000..2ea467a --- /dev/null +++ b/bin/topinf.ml @@ -0,0 +1,2427 @@ +[@@@ocaml.warning "-6-9-26-27-32-33-34"] + +module F = Fmt + +let _ = F.epr "topinf.ml comin at ya @." + +open Format +open Misc +open Parsetree +open Typedtree +open Types +open Trace +open Cmo_format +open Outcometree +open Ast_helper +open Lambda +open Translcore +open Translclass +open Translobj +open Debuginfo.Scoped_location +open Path +module String = Misc.Stdlib.String + +exception PPerror + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +type directive_info = { section : string; doc : string } + +(* Phase buffer that stores the last toplevel phrase (see [Location.input_phrase_buffer]). *) +let phrase_buffer = Buffer.create 1024 + +(* The table of toplevel value bindings and its accessors *) +let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty + +let getvalue name = + F.epr "Topinf.getvalue %s@." name; + try String.Map.find name !toplevel_value_bindings + with Not_found -> fatal_error (name ^ " unbound at toplevel") + +let setvalue name v = + F.epr "Topinf.setvalue %s@." name; + toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings + +let print_toplevel_value_bindings () = + String.Map.iter + (fun k v -> F.epr "toplevel_value_bindings: %s\n" k) + !toplevel_value_bindings + +(* copied in lots of ocaml/lambda/translmod.ml *) + +type unsafe_component = + | Unsafe_module_binding + | Unsafe_functor + | Unsafe_non_function + | Unsafe_typext + +type unsafe_info = + | Unsafe of { reason : unsafe_component; loc : Location.t; subid : Ident.t } + | Unnamed + +type error = + | Circular_dependency of (Ident.t * unsafe_info) list + | Conflicting_inline_attributes + +exception Error of Location.t * error + +let cons_opt x_opt xs = match x_opt with None -> xs | Some x -> x :: xs + +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some (Pident glob) + +let functor_path path param = + match path with None -> None | Some p -> Some (Papply (p, Pident param)) + +let field_path path field = + match path with None -> None | Some p -> Some (Pdot (p, Ident.name field)) + +(* Compile type extensions *) + +let transl_type_extension ~scopes env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor ~scopes env + (field_path rootpath ext.ext_id) + ext + in + Llet (Strict, Pgenval, ext.ext_id, lam, body)) + tyext.tyext_constructors body + +(* Compile a coercion *) + +let rec apply_coercion loc strict restr arg = + match restr with + | Tcoerce_none -> arg + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let get_field pos = + if pos < 0 then lambda_unit else Lprim (Pfield pos, [ Lvar id ], loc) + in + let lam = + Lprim + ( Pmakeblock (0, Immutable, None), + List.map (apply_coercion_field loc get_field) pos_cc_list, + loc ) + in + wrap_id_pos_list loc id_pos_list get_field lam) + | Tcoerce_functor (cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let carg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict arg [ (param, Pgenval) ] [ carg ] cc_res + | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type } -> + Translprim.transl_primitive loc pc_desc pc_env pc_type None + | Tcoerce_alias (env, path, cc) -> + let lam = transl_module_path loc env path in + name_lambda strict arg (fun _ -> apply_coercion loc Alias cc lam) + +and apply_coercion_field loc get_field (pos, cc) = + apply_coercion loc Alias cc (get_field pos) + +and apply_coercion_result loc strict funct params args cc_res = + match cc_res with + | Tcoerce_functor (cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let arg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict funct + ((param, Pgenval) :: params) + (arg :: args) cc_res + | _ -> + name_lambda strict funct (fun id -> + Lfunction + { + kind = Curried; + params = List.rev params; + return = Pgenval; + attr = + { + default_function_attribute with + is_a_functor = true; + stub = true; + }; + loc; + body = + apply_coercion loc Strict cc_res + (Lapply + { + ap_loc = loc; + ap_func = Lvar id; + ap_args = List.rev args; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + }); + }) + +and wrap_id_pos_list loc id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let lam, s = + List.fold_left + (fun (lam, s) (id', pos, c) -> + if Ident.Set.mem id' fv then + let id'' = Ident.create_local (Ident.name id') in + ( Llet + ( Alias, + Pgenval, + id'', + apply_coercion loc Alias c (get_field pos), + lam ), + Ident.Map.add id' id'' s ) + else (lam, s)) + (lam, Ident.Map.empty) id_pos_list + in + if s == Ident.Map.empty then lam else Lambda.rename s lam + +(* Compose two coercions + apply_coercion c1 (apply_coercion c2 e) behaves like + apply_coercion (compose_coercions c1 c2) e. *) + +let rec compose_coercions c1 c2 = + match (c1, c2) with + | Tcoerce_none, c2 -> c2 + | c1, Tcoerce_none -> c1 + | Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2) -> + let v2 = Array.of_list pc2 in + let ids1 = + List.map + (fun (id, pos1, c1) -> + let pos2, c2 = v2.(pos1) in + (id, pos2, compose_coercions c1 c2)) + ids1 + in + Tcoerce_structure + ( List.map + (fun pc -> + match pc with + | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> + (* These cases do not take an argument (the position is -1), + so they do not need adjusting. *) + pc + | p1, c1 -> + let p2, c2 = v2.(p1) in + (p2, compose_coercions c1 c2)) + pc1, + ids1 @ ids2 ) + | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> + Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) + | c1, Tcoerce_alias (env, path, c2) -> + Tcoerce_alias (env, path, compose_coercions c1 c2) + | _, _ -> fatal_error "Translmod.compose_coercions" + +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + +(* Record the primitive declarations occurring in the module compiled *) + +let primitive_declarations = ref ([] : Primitive.description list) + +let record_primitive = function + | { val_kind = Val_prim p; val_loc } -> + Translprim.check_primitive_arity val_loc p; + primitive_declarations := p :: !primitive_declarations + | _ -> () + +(* Utilities for compiling "module rec" definitions *) + +let mod_prim = Lambda.transl_prim "CamlinternalMod" + +let undefined_location loc = + let fname, line, char = Location.get_pos_info loc.Location.loc_start in + Lconst + (Const_block + ( 0, + [ + Const_base (Const_string (fname, loc, None)); + const_int line; + const_int char; + ] )) + +exception Initialization_failure of unsafe_info + +let init_shape id modl = + let rec init_shape_mod subid loc env mty = + match Mtype.scrape env mty with + | Mty_ident _ | Mty_alias _ -> + raise + (Initialization_failure + (Unsafe { reason = Unsafe_module_binding; loc; subid })) + | Mty_signature sg -> + Const_block (0, [ Const_block (0, init_shape_struct env sg) ]) + | Mty_functor _ -> + (* can we do better? *) + raise + (Initialization_failure + (Unsafe { reason = Unsafe_functor; loc; subid })) + and init_shape_struct env sg = + match sg with + | [] -> [] + | Sig_value (subid, { val_kind = Val_reg; val_type = ty; val_loc = loc }, _) + :: rem -> + let init_v = + match Ctype.expand_head env ty with + | { desc = Tarrow (_, _, _, _) } -> + const_int 0 (* camlinternalMod.Function *) + | { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t -> + const_int 1 (* camlinternalMod.Lazy *) + | _ -> + let not_a_function = + Unsafe { reason = Unsafe_non_function; loc; subid } + in + raise (Initialization_failure not_a_function) + in + init_v :: init_shape_struct env rem + | Sig_value (_, { val_kind = Val_prim _ }, _) :: rem -> + init_shape_struct env rem + | Sig_value _ :: _rem -> assert false + | Sig_type (id, tdecl, _, _) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext (subid, { ext_loc = loc }, _, _) :: _ -> + raise + (Initialization_failure + (Unsafe { reason = Unsafe_typext; loc; subid })) + | Sig_module (id, Mp_present, md, _, _) :: rem -> + init_shape_mod id md.md_loc env md.md_type + :: init_shape_struct + (Env.add_module_declaration ~check:false id Mp_present md env) + rem + | Sig_module (id, Mp_absent, md, _, _) :: rem -> + init_shape_struct + (Env.add_module_declaration ~check:false id Mp_absent md env) + rem + | Sig_modtype (id, minfo, _) :: rem -> + init_shape_struct (Env.add_modtype id minfo env) rem + | Sig_class _ :: rem -> + const_int 2 (* camlinternalMod.Class *) :: init_shape_struct env rem + | Sig_class_type _ :: rem -> init_shape_struct env rem + in + try + Ok + ( undefined_location modl.mod_loc, + Lconst (init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type) ) + with Initialization_failure reason -> Result.Error reason + +(* Reorder bindings to honor dependencies. *) + +type binding_status = + | Undefined + | Inprogress of int option (** parent node *) + | Defined + +type id_or_ignore_loc = Id of Ident.t | Ignore_loc of Lambda.scoped_location + +let extract_unsafe_cycle id status init cycle_start = + let info i = + match init.(i) with + | Result.Error r -> ( + match id.(i) with + | Id id -> (id, r) + | Ignore_loc _ -> + assert false (* Can't refer to something without a name. *)) + | Ok _ -> assert false + in + let rec collect stop l i = + match status.(i) with + | Inprogress None | Undefined | Defined -> assert false + | Inprogress (Some i) when i = stop -> info i :: l + | Inprogress (Some i) -> collect stop (info i :: l) i + in + collect cycle_start [] cycle_start + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id, _, _, _) -> id) bindings) + and loc = Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) + and init = Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.make num_bindings Undefined in + let res = ref [] in + let is_unsafe i = + match init.(i) with Ok _ -> false | Result.Error _ -> true + in + let init_res i = + match init.(i) with Result.Error _ -> None | Ok (a, b) -> Some (a, b) + in + let rec emit_binding parent i = + match status.(i) with + | Defined -> () + | Inprogress _ -> + status.(i) <- Inprogress parent; + let cycle = extract_unsafe_cycle id status init i in + raise (Error (loc.(i), Circular_dependency cycle)) + | Undefined -> + if is_unsafe i then ( + status.(i) <- Inprogress parent; + for j = 0 to num_bindings - 1 do + match id.(j) with + | Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j + | _ -> () + done); + res := (id.(i), init_res i, rhs.(i)) :: !res; + status.(i) <- Defined + in + for i = 0 to num_bindings - 1 do + match status.(i) with + | Undefined -> emit_binding None i + | Inprogress _ -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + | [] -> bind_strict bindings + | (Ignore_loc _, _, _) :: rem | (_, None, _) :: rem -> bind_inits rem + | (Id id, Some (loc, shape), _rhs) :: rem -> + Llet + ( Strict, + Pgenval, + id, + Lapply + { + ap_loc = Loc_unknown; + ap_func = mod_prim "init_mod"; + ap_args = [ loc; shape ]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + }, + bind_inits rem ) + and bind_strict = function + | [] -> patch_forwards bindings + | (Ignore_loc loc, None, rhs) :: rem -> + Lsequence (Lprim (Pignore, [ rhs ], loc), bind_strict rem) + | (Id id, None, rhs) :: rem -> + Llet (Strict, Pgenval, id, rhs, bind_strict rem) + | (_id, Some _, _rhs) :: rem -> bind_strict rem + and patch_forwards = function + | [] -> cont + | (Ignore_loc _, _, _rhs) :: rem | (_, None, _rhs) :: rem -> + patch_forwards rem + | (Id id, Some (_loc, shape), rhs) :: rem -> + Lsequence + ( Lapply + { + ap_loc = Loc_unknown; + ap_func = mod_prim "update_mod"; + ap_args = [ shape; Lvar id; rhs ]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + }, + patch_forwards rem ) + in + bind_inits bindings + +let compile_recmodule ~scopes compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun { mb_id = id; mb_name; mb_expr = modl; mb_loc = loc; _ } -> + let id_or_ignore_loc, shape = + match id with + | None -> + let loc = of_location ~scopes mb_name.loc in + (Ignore_loc loc, Result.Error Unnamed) + | Some id -> (Id id, init_shape id modl) + in + (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc)) + bindings)) + cont + +(* Code to translate class entries in a structure *) + +let transl_class_bindings ~scopes cl_list = + let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in + ( ids, + List.map + (fun ({ ci_id_class = id; ci_expr = cl; ci_virt = vf }, meths) -> + (id, transl_class ~scopes ids id meths cl vf)) + cl_list ) + +(* Compile one or more functors, merging curried functors to produce + multi-argument functors. Any [@inline] attribute on a functor that is + merged must be consistent with any other [@inline] attribute(s) on the + functor(s) being merged with. Such an attribute will be placed on the + resulting merged functor. *) + +let merge_inline_attributes attr1 attr2 loc = + match Lambda.merge_inline_attributes attr1 attr2 with + | Some attr -> attr + | None -> raise (Error (to_location loc, Conflicting_inline_attributes)) + +let merge_functors ~scopes mexp coercion root_path = + let rec merge ~scopes mexp coercion path acc inline_attribute = + let finished = (acc, mexp, path, coercion, inline_attribute) in + match mexp.mod_desc with + | Tmod_functor (param, body) -> + let inline_attribute' = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) + | Tcoerce_functor (arg_coercion, res_coercion) -> + (arg_coercion, res_coercion) + | _ -> fatal_error "Translmod.merge_functors: bad coercion" + in + let loc = of_location ~scopes mexp.mod_loc in + let path, param = + match param with + | Unit -> (None, Ident.create_local "*") + | Named (None, _, _) -> + let id = Ident.create_local "_" in + (functor_path path id, id) + | Named (Some id, _, _) -> (functor_path path id, id) + in + let inline_attribute = + merge_inline_attributes inline_attribute inline_attribute' loc + in + merge ~scopes body res_coercion path + ((param, loc, arg_coercion) :: acc) + inline_attribute + | _ -> finished + in + merge ~scopes mexp coercion root_path [] Default_inline + +let rec compile_functor ~scopes mexp coercion root_path loc = + let functor_params_rev, body, body_path, res_coercion, inline_attribute = + merge_functors ~scopes mexp coercion root_path + in + assert (List.length functor_params_rev >= 1); + (* cf. [transl_module] *) + let params, body = + List.fold_left + (fun (params, body) (param, loc, arg_coercion) -> + let param' = Ident.rename param in + let arg = apply_coercion loc Alias arg_coercion (Lvar param') in + let params = (param', Pgenval) :: params in + let body = Llet (Alias, Pgenval, param, arg, body) in + (params, body)) + ([], transl_module ~scopes res_coercion body_path body) + functor_params_rev + in + Lfunction + { + kind = Curried; + params; + return = Pgenval; + attr = + { + inline = inline_attribute; + specialise = Default_specialise; + local = Default_local; + is_a_functor = true; + stub = false; + }; + loc; + body; + } + +(* Compile a module expression *) + +and transl_module ~scopes cc rootpath mexp = + List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes; + let loc = of_location ~scopes mexp.mod_loc in + match mexp.mod_desc with + | Tmod_ident (path, _) -> + apply_coercion loc Strict cc (transl_module_path loc mexp.mod_env path) + | Tmod_structure str -> fst (transl_struct ~scopes loc [] cc rootpath str) + | Tmod_functor _ -> + oo_wrap mexp.mod_env true + (fun () -> compile_functor ~scopes mexp cc rootpath loc) + () + | Tmod_apply (funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + oo_wrap mexp.mod_env true + (apply_coercion loc Strict cc) + (Lapply + { + ap_loc = loc; + ap_func = transl_module ~scopes Tcoerce_none None funct; + ap_args = [ transl_module ~scopes ccarg None arg ]; + ap_tailcall = Default_tailcall; + ap_inlined = inlined_attribute; + ap_specialised = Default_specialise; + }) + | Tmod_constraint (arg, _, _, ccarg) -> + transl_module ~scopes (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack (arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp ~scopes arg) + +and transl_struct ~scopes loc fields cc rootpath { str_final_env; str_items; _ } + = + transl_structure ~scopes loc fields cc rootpath str_final_env str_items + +(* The function transl_structure is called by the bytecode compiler. + Some effort is made to compile in top to bottom order, in order to display + warning by increasing locations. *) +and transl_structure ~scopes loc fields cc rootpath final_env = function + | [] -> + let body, size = + match cc with + | Tcoerce_none -> + ( Lprim + ( Pmakeblock (0, Immutable, None), + List.map (fun id -> Lvar id) (List.rev fields), + loc ), + List.length fields ) + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + let v = Array.of_list (List.rev fields) in + let get_field pos = if pos < 0 then lambda_unit else Lvar v.(pos) in + let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in + let lam = + Lprim + ( Pmakeblock (0, Immutable, None), + List.map + (fun (pos, cc) -> + match cc with + | Tcoerce_primitive p -> + Translprim.transl_primitive + (of_location ~scopes p.pc_loc) + p.pc_desc p.pc_env p.pc_type None + | _ -> apply_coercion loc Strict cc (get_field pos)) + pos_cc_list, + loc ) + and id_pos_list = + List.filter + (fun (id, _, _) -> not (Ident.Set.mem id ids)) + id_pos_list + in + ( wrap_id_pos_list loc id_pos_list get_field lam, + List.length pos_cc_list ) + | _ -> fatal_error "Translmod.transl_structure" + in + (* This debugging event provides information regarding the structure + items. It is ignored by the OCaml debugger but is used by + Js_of_ocaml to preserve variable names. *) + ( (if !Clflags.debug && not !Clflags.native_code then + Levent + ( body, + { + lev_loc = loc; + lev_kind = Lev_pseudo; + lev_repr = None; + lev_env = final_env; + } ) + else body), + size ) + | item :: rem -> ( + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = + transl_structure ~scopes loc fields cc rootpath final_env rem + in + (Lsequence (transl_exp ~scopes expr, body), size) + | Tstr_value (rec_flag, pat_expr_list) -> + (* Translate bindings first *) + let mk_lam_let = + transl_let ~scopes ~in_structure:true rec_flag pat_expr_list + in + let ext_fields = + List.rev_append (let_bound_idents pat_expr_list) fields + in + (* Then, translate remainder of struct *) + let body, size = + transl_structure ~scopes loc ext_fields cc rootpath final_env rem + in + (mk_lam_let body, size) + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_structure ~scopes loc fields cc rootpath final_env rem + | Tstr_type _ -> + transl_structure ~scopes loc fields cc rootpath final_env rem + | Tstr_typext tyext -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure ~scopes loc + (List.rev_append ids fields) + cc rootpath final_env rem + in + (transl_type_extension ~scopes item.str_env rootpath tyext body, size) + | Tstr_exception ext -> + let id = ext.tyexn_constructor.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure ~scopes loc (id :: fields) cc rootpath final_env + rem + in + ( Llet + ( Strict, + Pgenval, + id, + transl_extension_constructor ~scopes item.str_env path + ext.tyexn_constructor, + body ), + size ) + | Tstr_module ({ mb_presence = Mp_present } as mb) -> ( + let id = mb.mb_id in + (* Translate module first *) + let subscopes = + match id with + | None -> scopes + | Some id -> enter_module_definition ~scopes id + in + let module_body = + transl_module ~scopes:subscopes Tcoerce_none + (Option.bind id (field_path rootpath)) + mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + (* Translate remainder second *) + let body, size = + transl_structure ~scopes loc (cons_opt id fields) cc rootpath + final_env rem + in + match id with + | None -> + ( Lsequence + ( Lprim + ( Pignore, + [ module_body ], + of_location ~scopes mb.mb_name.loc ), + body ), + size ) + | Some id -> + let module_body = + Levent + ( module_body, + { + lev_loc = of_location ~scopes mb.mb_loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + } ) + in + ( Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), + size )) + | Tstr_module ({ mb_presence = Mp_absent } as mb) -> + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_attributes; + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_expr.mod_attributes; + transl_structure ~scopes loc fields cc rootpath final_env rem + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append + (List.filter_map (fun mb -> mb.mb_id) bindings) + fields + in + let body, size = + transl_structure ~scopes loc ext_fields cc rootpath final_env rem + in + let lam = + compile_recmodule ~scopes + (fun id modl loc -> + match id with + | None -> transl_module ~scopes Tcoerce_none None modl + | Some id -> + let module_body = + transl_module + ~scopes:(enter_module_definition ~scopes id) + Tcoerce_none (field_path rootpath id) modl + in + Levent + ( module_body, + { + lev_loc = of_location ~scopes loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + } )) + bindings body + in + (lam, size) + | Tstr_class cl_list -> + let ids, class_bindings = transl_class_bindings ~scopes cl_list in + let body, size = + transl_structure ~scopes loc + (List.rev_append ids fields) + cc rootpath final_env rem + in + (Lletrec (class_bindings, body), size) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec rebind_idents pos newfields = function + | [] -> + transl_structure ~scopes loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + ( Llet + ( Alias, + Pgenval, + id, + Lprim + ( Pfield pos, + [ Lvar mid ], + of_location ~scopes incl.incl_loc ), + body ), + size ) + in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure_module modl, + Pgenval, + mid, + transl_module ~scopes Tcoerce_none None modl, + body ), + size ) + | Tstr_open od -> ( + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + match od.open_bound_items with + | [] when pure = Alias -> + transl_structure ~scopes loc fields cc rootpath final_env rem + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec rebind_idents pos newfields = function + | [] -> + transl_structure ~scopes loc newfields cc rootpath final_env + rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + ( Llet + ( Alias, + Pgenval, + id, + Lprim + ( Pfield pos, + [ Lvar mid ], + of_location ~scopes od.open_loc ), + body ), + size ) + in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure, + Pgenval, + mid, + transl_module ~scopes Tcoerce_none None od.open_expr, + body ), + size )) + | Tstr_modtype _ | Tstr_class_type _ | Tstr_attribute _ -> + transl_structure ~scopes loc fields cc rootpath final_env rem) + +(* Compile a toplevel phrase *) + +let toploop_ident = Ident.create_persistent "Topinf" + +let toploop_getvalue_pos = 0 (* position of getvalue in module Topinf *) + +let toploop_setvalue_pos = 1 (* position of setvalue in module Topinf *) + +let aliased_idents = ref Ident.empty + +let set_toplevel_unique_name id = + aliased_idents := Ident.add id (Ident.unique_toplevel_name id) !aliased_idents + +let toplevel_name id = + F.epr "toplevel_name: %s @." (Ident.name id); + try Ident.find_same id !aliased_idents with Not_found -> Ident.name id + +let toploop_getvalue id = + F.epr "toploop_getvalue: %s @." (Ident.name id); + Lapply + { + ap_loc = Loc_unknown; + ap_func = + Lprim + ( Pfield toploop_getvalue_pos, + [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], + Loc_unknown ); + ap_args = + [ + Lconst + (Const_base (Const_string (toplevel_name id, Location.none, None))); + ]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + +let toploop_setvalue id lam = + F.epr "toploop_setvalue: %s @." (Ident.name id); + Lapply + { + ap_loc = Loc_unknown; + ap_func = + Lprim + ( Pfield toploop_setvalue_pos, + [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], + Loc_unknown ); + ap_args = + [ + Lconst + (Const_base (Const_string (toplevel_name id, Location.none, None))); + lam; + ]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + +let toploop_setvalue_id id = + F.epr "toploop_setvalue_id: %s @." (Ident.name id); + toploop_setvalue id (Lambda.Lvar id) + +let close_toplevel_term (lam, ()) = + Ident.Set.fold + (fun id l -> Lambda.Llet (Strict, Pgenval, id, toploop_getvalue id, l)) + (Lambda.free_variables lam) + lam + +let transl_toplevel_item ~scopes (item : structure_item) = + match item.str_desc with + | Tstr_eval (expr, _) + | Tstr_value + (Nonrecursive, [ { vb_pat = { pat_desc = Tpat_any }; vb_expr = expr } ]) + -> + (* special compilation for toplevel "let _ = expr", so + that Toploop can display the result of the expression. + Otherwise, the normal compilation would result + in a Lsequence returning unit. *) + Translcore.transl_exp ~scopes expr + | Tstr_value (rec_flag, pat_expr_list) -> + let idents = let_bound_idents pat_expr_list in + transl_let ~scopes ~in_structure:true rec_flag pat_expr_list + (make_sequence toploop_setvalue_id idents) + | Tstr_typext tyext -> + let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension ~scopes item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.tyexn_constructor.ext_id; + toploop_setvalue ext.tyexn_constructor.ext_id + (transl_extension_constructor ~scopes item.str_env None + ext.tyexn_constructor) + | Tstr_module { mb_id = None; mb_presence = Mp_present; mb_expr = modl } -> + transl_module ~scopes Tcoerce_none None modl + | Tstr_module { mb_id = Some id; mb_presence = Mp_present; mb_expr = modl } -> + (* we need to use the unique name for the module because of issues + with "open" (PR#8133) *) + set_toplevel_unique_name id; + let lam = + transl_module + ~scopes:(enter_module_definition ~scopes id) + Tcoerce_none (Some (Pident id)) modl + in + toploop_setvalue id lam + | Tstr_recmodule bindings -> + let idents = List.filter_map (fun mb -> mb.mb_id) bindings in + compile_recmodule ~scopes + (fun id modl _loc -> + match id with + | None -> transl_module ~scopes Tcoerce_none None modl + | Some id -> + transl_module + ~scopes:(enter_module_definition ~scopes id) + Tcoerce_none (Some (Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) + | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) + let ids, class_bindings = transl_class_bindings ~scopes cl_list in + List.iter set_toplevel_unique_name ids; + Lletrec (class_bindings, make_sequence toploop_setvalue_id ids) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec set_idents pos = function + | [] -> lambda_unit + | id :: ids -> + Lsequence + ( toploop_setvalue id + (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), + set_idents (pos + 1) ids ) + in + Llet + ( Strict, + Pgenval, + mid, + transl_module ~scopes Tcoerce_none None modl, + set_idents 0 ids ) + | Tstr_primitive descr -> + record_primitive descr.val_val; + lambda_unit + | Tstr_open od -> ( + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + match od.open_bound_items with + | [] when pure = Alias -> lambda_unit + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec set_idents pos = function + | [] -> lambda_unit + | id :: ids -> + Lsequence + ( toploop_setvalue id + (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), + set_idents (pos + 1) ids ) + in + Llet + ( pure, + Pgenval, + mid, + transl_module ~scopes Tcoerce_none None od.open_expr, + set_idents 0 ids )) + | Tstr_module ({ mb_presence = Mp_absent } as mb) -> + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_attributes; + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_expr.mod_attributes; + lambda_unit + | Tstr_modtype _ | Tstr_type _ | Tstr_class_type _ | Tstr_attribute _ -> + lambda_unit + +let transl_toplevel_item_and_close ~scopes itm = + close_toplevel_term + (transl_label_init (fun () -> (transl_toplevel_item ~scopes itm, ()))) + +let transl_toplevel_definition str = + Translobj.reset_labels (); + Translprim.clear_used_primitives (); + Lambda.make_sequence + (transl_toplevel_item_and_close ~scopes:empty_scopes) + str.str_items + +(* 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 + let name = toplevel_name id in + try String.Map.find name !toplevel_value_bindings + with Not_found -> + raise (Symtable.Error (Symtable.Undefined_global name))) + | 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 + +let eval_class_path env path = eval_path Env.find_class_address env path + +(* To print values *) + +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 + +module Printer = Genprintval.Make (Obj) (EvalPath) + +let max_printer_depth = ref 100 + +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value + +let print_out_type = Oprint.out_type + +let print_out_class_type = Oprint.out_class_type + +let print_out_module_type = Oprint.out_module_type + +let print_out_type_extension = Oprint.out_type_extension + +let print_out_sig_item = Oprint.out_sig_item + +let print_out_signature = Oprint.out_signature + +let print_out_phrase = Oprint.out_phrase + +let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) + +let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) + env obj ty + +let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + +type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + +let install_printer = Printer.install_printer + +let install_generic_printer = Printer.install_generic_printer + +let install_generic_printer' = Printer.install_generic_printer' + +let remove_printer = Printer.remove_printer + +(* 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_loc + +let print_error = Location.print_report + +let print_warning = Location.print_warning + +let input_name = Location.input_name + +let parse_mod_use_file name lb = + let modname = + String.capitalize_ascii (Filename.remove_extension (Filename.basename name)) + in + let items = + List.concat + (List.map + (function Ptop_def s -> s | Ptop_dir _ -> []) + (!parse_use_file lb)) + in + [ + Ptop_def + [ + Str.module_ + (Mb.mk (Location.mknoloc (Some modname)) (Mod.structure items)); + ]; + ] + +(* Hook for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +type event = .. + +type event += Startup | After_setup + +let hooks = ref [] + +let add_hook f = hooks := f :: !hooks + +let () = add_hook (function Startup -> !toplevel_startup_hook () | _ -> ()) + +let run_hooks hook = List.iter (fun f -> f hook) !hooks + +(* Load in-core and execute a lambda term *) + +let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) + env obj ty + +let may_trace = ref false (* Global lock on tracing *) + +type evaluation_outcome = Result of Obj.t | Exception of exn + +let backtrace = ref None + +let record_backtrace () = + if Printexc.backtrace_status () then + backtrace := Some (Printexc.get_backtrace ()) + +let load_lambda ppf lam = + if !Clflags.dump_rawlambda then + Format.fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then Format.fprintf ppf "%a@." Printlambda.lambda slam; + let init_code, fun_code = Bytegen.compile_phrase slam in + if !Clflags.dump_instr then + Format.fprintf ppf "%a%a@." Printinstr.instrlist init_code + Printinstr.instrlist fun_code; + let code, reloc, events = Emitcode.to_memory init_code fun_code in + let can_free = fun_code = [] in + let initial_symtable = Symtable.current_state () in + Symtable.patch_object code reloc; + Symtable.check_global_initialized reloc; + Symtable.update_global_table (); + let initial_bindings = !toplevel_value_bindings in + let bytecode, closure = Meta.reify_bytecode code [| events |] None in + match + may_trace := true; + Fun.protect + ~finally:(fun () -> + may_trace := false; + if can_free then Meta.release_bytecode bytecode) + closure + with + | retval -> Result retval + | exception x -> + record_backtrace (); + toplevel_value_bindings := initial_bindings; + (* PR#6211 *) + Symtable.restore_state initial_symtable; + Exception x + +(* Print the outcome of an evaluation *) +let pr_item = + Printtyp.print_items (fun env -> function + | Sig_value (id, { val_kind = Val_reg; val_type }, _) -> + Some (outval_of_value env (getvalue (toplevel_name id)) val_type) + | _ -> None) + +let read_interactive_input = ref (fun _ _ -> 0) + +(* Toplevel initialization. Performed here instead of at the + beginning of loop() so that user code linked in with ocamlmktop + can call directives from Topdirs. *) +let _ = + (*if !Sys.interactive then (* PR#6108 *) + invalid_arg "The ocamltoplevel.cma library from compiler-libs \ + cannot be loaded inside the OCaml toplevel"; *) + Sys.interactive := true; + let crc_intfs = Symtable.init_toplevel () in + Compmisc.init_path (); + Env.import_crcs ~source:Sys.executable_name crc_intfs; + () + +(* The current typing environment for the toplevel *) +let toplevel_env = ref Env.empty + +let initialize_toplevel_env () = toplevel_env := Compmisc.initial_env () + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + let expand = Misc.expand_directory Config.standard_library in + let current_load_path = Load_path.get_paths () in + let load_path = + List.concat + [ + [ "" ]; + List.map expand (List.rev !Compenv.first_include_dirs); + List.map expand (List.rev !Clflags.include_dirs); + List.map expand (List.rev !Compenv.last_include_dirs); + current_load_path; + [ expand "+camlp4" ]; + ] + in + Load_path.init load_path; + Dll.add_path load_path + +(* Print an exception produced by an evaluation *) + +let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + +let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + print_out_exception ppf exn outv; + if Printexc.backtrace_status () then + match !backtrace with + | None -> () + | Some b -> + print_string b; + backtrace := None + +(* Inserting new toplevel directives *) +let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) + +let directive_info_table = + (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) + +let add_directive name dir_fun dir_info = + Hashtbl.add directive_table name dir_fun; + Hashtbl.add directive_info_table name dir_info + +(* Execute a toplevel phrase *) +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> ( + let oldenv = !toplevel_env in + Typecore.reset_delayed_checks (); + let str, sg, sn, newenv = Typemod.type_toplevel_phrase oldenv sstr in + if !Clflags.dump_typedtree then Printtyped.implementation ppf str; + let sg' = Typemod.Signature_names.simplify newenv sn sg in + ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); + Typecore.force_delayed_checks (); + let lam = transl_toplevel_definition str in + Warnings.check_fatal (); + try + toplevel_env := newenv; + let res = load_lambda ppf lam in + let out_phr = + match res with + | Result v -> + if print_outcome then + Printtyp.wrap_printing_env ~error:false oldenv (fun () -> + match str.str_items with + | [ + { + str_desc = + ( Tstr_eval (exp, _) + | Tstr_value + ( Asttypes.Nonrecursive, + [ + { + vb_pat = { pat_desc = Tpat_any }; + vb_expr = exp; + }; + ] ) ); + }; + ] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | [] -> Ophr_signature [] + | _ -> Ophr_signature (pr_item oldenv sg')) + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + if exn = Out_of_memory then Gc.full_major (); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + (if Printexc.backtrace_status () then + match !backtrace with + | None -> () + | Some b -> + pp_print_string ppf b; + pp_print_flush ppf (); + backtrace := None); + match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + with x -> + toplevel_env := oldenv; + raise x) + | Ptop_dir { pdir_name = { Location.txt = dir_name }; pdir_arg } -> ( + let d = + try Some (Hashtbl.find directive_table dir_name) + with Not_found -> None + in + match d with + | None -> + fprintf ppf "Unknown directive `%s'." dir_name; + let directives = + Hashtbl.fold (fun dir _ acc -> dir :: acc) directive_table [] + in + Misc.did_you_mean ppf (fun () -> Misc.spellcheck directives dir_name); + fprintf ppf "@."; + false + | Some d -> ( + match (d, pdir_arg) with + | Directive_none f, None -> + f (); + true + | Directive_string f, Some { pdira_desc = Pdir_string s } -> + f s; + true + | Directive_int f, Some { pdira_desc = Pdir_int (n, None) } -> ( + match Int_literal_converter.int n with + | n -> + f n; + true + | exception _ -> + fprintf ppf + "Integer literal exceeds the range of representable \ + integers for directive `%s'.@." + dir_name; + false) + | Directive_int _, Some { pdira_desc = Pdir_int (_, Some _) } -> + fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name; + false + | Directive_ident f, Some { pdira_desc = Pdir_ident lid } -> + f lid; + true + | Directive_bool f, Some { pdira_desc = Pdir_bool b } -> + f b; + true + | _ -> + fprintf ppf "Wrong type of argument for directive `%s'.@." + dir_name; + false)) + +let execute_phrase print_outcome ppf phr = + try execute_phrase print_outcome ppf phr + with exn -> + Warnings.reset_fatal (); + raise exn + +(* Read and execute commands from a file, or from stdin if [name] is "". *) + +let use_print_results = ref true + +let preprocess_phrase ppf phr = + let phr = + match phr with + | Ptop_def str -> + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str + | phr -> phr + in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + if !Clflags.dump_source then Pprintast.top_phrase ppf phr; + phr + +let use_channel ppf ~wrap_in_module ic name filename = + let lb = Lexing.from_channel ic in + Warnings.reset_fatal (); + Location.init lb filename; + (* Skip initial #! line if any *) + Lexer.skip_hash_bang lb; + protect_refs + [ R (Location.input_name, filename); R (Location.input_lexbuf, Some lb) ] + (fun () -> + try + List.iter + (fun ph -> + let ph = preprocess_phrase ppf ph in + if not (execute_phrase !use_print_results ppf ph) then raise Exit) + (if wrap_in_module then parse_mod_use_file name lb + else !parse_use_file lb); + true + with + | Exit -> false + | Sys.Break -> + fprintf ppf "Interrupted.@."; + false + | x -> + Location.report_exception ppf x; + false) + +let use_output ppf command = + let fn = Filename.temp_file "ocaml" "_toploop.ml" in + Misc.try_finally + ~always:(fun () -> try Sys.remove fn with Sys_error _ -> ()) + (fun () -> + match + Printf.ksprintf Sys.command "%s > %s" command (Filename.quote fn) + with + | 0 -> + 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)") + | 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)" + | _ -> ( + 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) + | 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 use_silently ppf name = + protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) + +module Topdirs = struct + (* Toplevel directives *) + + (* The standard output formatter *) + let std_out = ref std_formatter + + (* Directive sections (used in #help) *) + let section_general = "General" + + let section_run = "Loading code" + + let section_env = "Environment queries" + + let section_print = "Pretty-printing" + + let section_trace = "Tracing" + + let section_options = "Compiler options" + + let section_undocumented = "Undocumented" + + (* we will print the sections in the first list, + then all user-defined sections, + then the sections in the second list, + then all undocumented directives *) + let order_of_sections = + ( [ section_general; section_run; section_env ], + [ section_print; section_trace; section_options; section_undocumented ] ) + (* Do not forget to keep the directives synchronized with the manual in + manual/manual/cmds/top.etex *) + + (* To quit *) + + let dir_quit () = raise (Compenv.Exit_with_status 0) + + let _ = + add_directive "quit" (Directive_none dir_quit) + { section = section_general; doc = "Exit the toplevel." } + + (* To add a directory to the load path *) + + let dir_directory s = + let d = expand_directory Config.standard_library s in + Dll.add_path [ d ]; + let dir = Load_path.Dir.create d in + Load_path.add dir; + toplevel_env := + Stdlib.String.Set.fold + (fun name env -> + Env.add_persistent_structure (Ident.create_persistent name) env) + (Env.persistent_structures_of_dir dir) + !toplevel_env + + let _ = + add_directive "directory" (Directive_string dir_directory) + { + section = section_run; + doc = + "Add the given directory to search path for source and compiled \ + files."; + } + + (* To remove a directory from the load path *) + let dir_remove_directory s = + let d = expand_directory Config.standard_library s in + let keep id = + match Load_path.find_uncap (Ident.name id ^ ".cmi") with + | exception Not_found -> true + | fn -> Filename.dirname fn <> d + in + toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env; + Load_path.remove_dir s; + Dll.remove_path [ d ] + + let _ = + add_directive "remove_directory" (Directive_string dir_remove_directory) + { + section = section_run; + doc = "Remove the given directory from the search path."; + } + (* To change the current directory *) + + let dir_cd s = Sys.chdir s + + let _ = + add_directive "cd" (Directive_string dir_cd) + { section = section_run; doc = "Change the current working directory." } + (* Load in-core a .cmo file *) + + exception Load_failed + + let check_consistency ppf filename cu = + try Env.import_crcs ~source:filename cu.cu_imports + with + | Persistent_env.Consistbl.Inconsistency + { unit_name = name; inconsistent_source = user; original_source = auth } + -> + fprintf ppf "@[The files %s@ and %s@ disagree over interface %s@]@." + user auth name; + raise Load_failed + + let load_compunit ic filename ppf compunit = + check_consistency ppf filename compunit; + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = LongString.create code_size in + LongString.input_bytes_into code ic compunit.cu_codesize; + LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + LongString.blit_string "\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 (); + let events = + if compunit.cu_debug = 0 then [||] + else ( + seek_in ic compunit.cu_debug; + [| input_value ic |]) + in + try + may_trace := true; + let _bytecode, closure = Meta.reify_bytecode code events None in + ignore (closure ()); + may_trace := false + with exn -> + record_backtrace (); + may_trace := false; + Symtable.restore_state initial_symtable; + print_exception_outcome ppf exn; + raise Load_failed + + let rec load_file recursive ppf name = + let filename = try Some (Load_path.find name) with Not_found -> None in + match filename with + | None -> + fprintf ppf "Cannot find file %s.@." name; + false + | Some filename -> + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> really_load_file recursive ppf name filename ic) + + and really_load_file recursive ppf name filename ic = + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in + try + if buffer = Config.cmo_magic_number then ( + let compunit_pos = input_binary_int ic in + (* Go to descriptor *) + seek_in ic compunit_pos; + let cu : compilation_unit = input_value ic in + if recursive then + List.iter + (function + | Reloc_getglobal id, _ when not (Symtable.is_global_defined id) + -> ( + let file = Ident.name id ^ ".cmo" in + match Load_path.find_uncap file with + | exception Not_found -> () + | file -> + if not (load_file recursive ppf file) then + raise Load_failed) + | _ -> ()) + cu.cu_reloc; + load_compunit ic filename ppf cu; + true) + else if buffer = Config.cma_magic_number then ( + let toc_pos = input_binary_int ic in + (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : library) in + List.iter + (fun dllib -> + let name = Dll.extract_dll_name dllib in + try Dll.open_dlls Dll.For_execution [ name ] + with Failure reason -> + fprintf ppf + "Cannot load required shared library %s.@.Reason: %s.@." name + reason; + raise Load_failed) + lib.lib_dllibs; + List.iter (load_compunit ic filename ppf) lib.lib_units; + true) + else ( + fprintf ppf "File %s is not a bytecode object file.@." name; + false) + with Load_failed -> false + + let dir_load ppf name = ignore (load_file false ppf name) + + let _ = + add_directive "load" + (Directive_string (dir_load !std_out)) + { + section = section_run; + doc = "Load in memory a bytecode object, produced by ocamlc."; + } + + let dir_load_rec ppf name = ignore (load_file true ppf name) + + let _ = + add_directive "load_rec" + (Directive_string (dir_load_rec !std_out)) + { + section = section_run; + doc = "As #load, but loads dependencies recursively."; + } + + let load_file = load_file false + + (* Load commands from a file *) + + let dir_use ppf name = ignore (use_file ppf name) + + let dir_use_output ppf name = ignore (use_output ppf name) + + let dir_mod_use ppf name = ignore (mod_use_file ppf name) + + let _ = + add_directive "use" + (Directive_string (dir_use !std_out)) + { + section = section_run; + doc = "Read, compile and execute source phrases from the given file."; + } + + let _ = + add_directive "use_output" + (Directive_string (dir_use_output !std_out)) + { + section = section_run; + doc = + "Execute a command and read, compile and execute source phrases from \ + its output."; + } + + let _ = + add_directive "mod_use" + (Directive_string (dir_mod_use !std_out)) + { + section = section_run; + doc = + "Usage is identical to #use but #mod_use wraps the contents in a \ + module."; + } + + (* Install, remove a printer *) + + let filter_arrow ty = + let ty = Ctype.expand_head !toplevel_env ty in + match ty.desc with + | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) + | _ -> None + + let rec extract_last_arrow desc = + match filter_arrow desc with + | None -> raise (Ctype.Unify []) + | Some ((_, r) as res) -> ( + try extract_last_arrow r with Ctype.Unify _ -> res) + + let extract_target_type ty = fst (extract_last_arrow ty) + + let extract_target_parameters ty = + let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in + match ty.desc with + | Tconstr (path, (_ :: _ as args), _) + when Ctype.all_distinct_vars !toplevel_env args -> + Some (path, args) + | _ -> None + + type 'a printer_type_new = Format.formatter -> 'a -> unit + + type 'a printer_type_old = 'a -> unit + + let printer_type ppf typename = + let printer_type = + match + Env.find_type_by_name (Ldot (Lident "Topdirs", typename)) !toplevel_env + with + | path, _ -> path + | exception Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit + in + printer_type + + let match_simple_printer_type desc printer_type = + Ctype.begin_def (); + let ty_arg = Ctype.newvar () in + Ctype.unify !toplevel_env + (Ctype.newconstr printer_type [ ty_arg ]) + (Ctype.instance desc.val_type); + Ctype.end_def (); + Ctype.generalize ty_arg; + (ty_arg, None) + + let match_generic_printer_type desc path args printer_type = + Ctype.begin_def (); + let args = List.map (fun _ -> Ctype.newvar ()) args in + let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in + let ty_args = + List.map (fun ty_var -> Ctype.newconstr printer_type [ ty_var ]) args + in + let ty_expected = + List.fold_right + (fun ty_arg ty -> + Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown))) + ty_args + (Ctype.newconstr printer_type [ ty_target ]) + in + Ctype.unify !toplevel_env ty_expected (Ctype.instance desc.val_type); + Ctype.end_def (); + Ctype.generalize ty_expected; + if not (Ctype.all_distinct_vars !toplevel_env args) then + raise (Ctype.Unify []); + (ty_expected, Some (path, ty_args)) + + let match_printer_type ppf desc = + let printer_type_new = printer_type ppf "printer_type_new" in + let printer_type_old = printer_type ppf "printer_type_old" in + try (match_simple_printer_type desc printer_type_new, false) + with Ctype.Unify _ -> ( + try (match_simple_printer_type desc printer_type_old, true) + with Ctype.Unify _ as exn -> ( + match extract_target_parameters desc.val_type with + | None -> raise exn + | Some (path, args) -> + (match_generic_printer_type desc path args printer_type_new, false))) + + let find_printer_type ppf lid = + match Env.find_value_by_name lid !toplevel_env with + | path, desc -> ( + match match_printer_type ppf desc with + | ty_arg, is_old_style -> (ty_arg, path, is_old_style) + | exception Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid; + raise Exit) + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Exit + + let dir_install_printer ppf lid = + try + let (ty_arg, ty), path, is_old_style = find_printer_type ppf lid in + let v = eval_value_path !toplevel_env path in + match ty with + | None -> + let print_function = + if is_old_style then fun _formatter repr -> Obj.obj v (Obj.obj repr) + else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) + in + install_printer path ty_arg print_function + | Some (ty_path, ty_args) -> + let rec build v = function + | [] -> + let print_function = + if is_old_style then fun _formatter repr -> + Obj.obj v (Obj.obj repr) + else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) + in + Zero print_function + | _ :: args -> + Succ (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) + in + install_generic_printer' path ty_path (build v ty_args) + with Exit -> () + + let dir_remove_printer ppf lid = + try + let _ty_arg, path, _is_old_style = find_printer_type ppf lid in + try remove_printer path + with Not_found -> + fprintf ppf "No printer named %a.@." Printtyp.longident lid + with Exit -> () + + let _ = + add_directive "install_printer" + (Directive_ident (dir_install_printer !std_out)) + { + section = section_print; + doc = "Registers a printer for values of a certain type."; + } + + let _ = + add_directive "remove_printer" + (Directive_ident (dir_remove_printer !std_out)) + { + section = section_print; + doc = "Remove the named function from the table of toplevel printers."; + } + + (* The trace *) + + external current_environment : unit -> Obj.t = "caml_get_current_environment" + + let tracing_function_ptr = + get_code_pointer + (Obj.repr (fun arg -> Trace.print_trace (current_environment ()) arg)) + + let dir_trace ppf lid = + match Env.find_value_by_name lid !toplevel_env with + | path, desc -> ( + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim _ -> + fprintf ppf "%a is an external function and cannot be traced.@." + Printtyp.longident lid + | _ -> + let clos = eval_value_path !toplevel_env path in + (* Nothing to do if it's not a closure *) + if + Obj.is_block clos + && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && + match Ctype.(repr (expand_head !toplevel_env desc.val_type)) with + | { desc = Tarrow _ } -> true + | _ -> false + then ( + match is_traced clos with + | Some opath -> + fprintf ppf "%a is already traced (under the name %a).@." + Printtyp.path path Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { + path; + closure = clos; + actual_code = get_code_pointer clos; + instrumented_fun = + instrument_closure !toplevel_env lid ppf desc.val_type; + } + :: !traced_functions; + (* Redirect the code field of the closure to point + to the instrumentation function *) + set_code_pointer clos tracing_function_ptr; + fprintf ppf "%a is now traced.@." Printtyp.longident lid) + else fprintf ppf "%a is not a function.@." Printtyp.longident lid) + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid + + let dir_untrace ppf lid = + match Env.find_value_by_name lid !toplevel_env with + | path, _desc -> + let rec remove = function + | [] -> + fprintf ppf "%a was not traced.@." Printtyp.longident lid; + [] + | f :: rem -> + if Path.same f.path path then ( + set_code_pointer f.closure f.actual_code; + fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; + rem) + else f :: remove rem + in + traced_functions := remove !traced_functions + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid + + let dir_untrace_all ppf () = + List.iter + (fun f -> + set_code_pointer f.closure f.actual_code; + fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) + !traced_functions; + traced_functions := [] + + let parse_warnings ppf iserr s = + try Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err + + (* Typing information *) + + let trim_signature = function + | Mty_signature sg -> + Mty_signature + (List.map + (function + | Sig_module (id, pres, md, rs, priv) -> + let attribute = + Ast_helper.Attr.mk (Location.mknoloc "...") + (Parsetree.PStr []) + in + Sig_module + ( id, + pres, + { md with md_attributes = attribute :: md.md_attributes }, + rs, + priv ) + (*| Sig_modtype (id, Modtype_manifest mty) -> + Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) + | item -> item) + sg) + | mty -> mty + + let show_prim to_sig ppf lid = + let env = !toplevel_env in + let loc = Location.none in + try + let s = + match lid with + | Longident.Lident s -> s + | Longident.Ldot (_, s) -> s + | Longident.Lapply _ -> + fprintf ppf "Invalid path %a@." Printtyp.longident lid; + raise Exit + in + let id = Ident.create_persistent s in + let sg = to_sig env loc id lid in + Printtyp.wrap_printing_env ~error:false env (fun () -> + fprintf ppf "@[%a@]@." Printtyp.signature sg) + with + | Not_found -> fprintf ppf "@[Unknown element.@]@." + | Exit -> () + + let all_show_funs = ref [] + + let reg_show_prim name to_sig doc = + all_show_funs := to_sig :: !all_show_funs; + add_directive name + (Directive_ident (show_prim to_sig !std_out)) + { section = section_env; doc } + + let () = + reg_show_prim "show_val" + (fun env loc id lid -> + let _path, desc = Env.lookup_value ~loc lid env in + [ Sig_value (id, desc, Exported) ]) + "Print the signature of the corresponding value." + + let () = + reg_show_prim "show_type" + (fun env loc id lid -> + let _path, desc = Env.lookup_type ~loc lid env in + [ Sig_type (id, desc, Trec_not, Exported) ]) + "Print the signature of the corresponding type constructor." + + (* Each registered show_prim function is called in turn + * and any output produced is sent to std_out. + * Two show_prim functions are needed for constructors, + * one for exception constructors and another for + * non-exception constructors (normal and extensible variants). *) + let is_exception_constructor env type_expr = + Ctype.equal env true [ type_expr ] [ Predef.type_exn ] + + let is_extension_constructor = function + | Cstr_extension _ -> true + | _ -> false + + let () = + (* This show_prim function will only show constructor types + * that are not also exception types. *) + reg_show_prim "show_constructor" + (fun env loc id lid -> + let desc = Env.lookup_constructor ~loc Env.Positive lid env in + if is_exception_constructor env desc.cstr_res then raise Not_found; + let path = + match Ctype.repr desc.cstr_res with + | { desc = Tconstr (path, _, _) } -> path + | _ -> raise Not_found + in + let type_decl = Env.find_type path env in + if is_extension_constructor desc.cstr_tag then + let ret_type = + if desc.cstr_generalized then Some desc.cstr_res else None + in + let ext = + { + ext_type_path = path; + ext_type_params = type_decl.type_params; + ext_args = Cstr_tuple desc.cstr_args; + ext_ret_type = ret_type; + ext_private = Asttypes.Public; + ext_loc = desc.cstr_loc; + ext_attributes = desc.cstr_attributes; + ext_uid = desc.cstr_uid; + } + in + [ Sig_typext (id, ext, Text_first, Exported) ] + else + (* make up a fake Ident.t as type_decl : Types.type_declaration + * does not have an Ident.t yet. Ident.create_presistent is a + * good choice because it has no side-effects. + * *) + let type_id = Ident.create_persistent (Path.name path) in + [ Sig_type (type_id, type_decl, Trec_first, Exported) ]) + "Print the signature of the corresponding value constructor." + + let () = + reg_show_prim "show_exception" + (fun env loc id lid -> + let desc = Env.lookup_constructor ~loc Env.Positive lid env in + if not (is_exception_constructor env desc.cstr_res) then raise Not_found; + let ret_type = + if desc.cstr_generalized then Some Predef.type_exn else None + in + let ext = + { + ext_type_path = Predef.path_exn; + ext_type_params = []; + ext_args = Cstr_tuple desc.cstr_args; + ext_ret_type = ret_type; + ext_private = Asttypes.Public; + ext_loc = desc.cstr_loc; + ext_attributes = desc.cstr_attributes; + ext_uid = desc.cstr_uid; + } + in + [ Sig_typext (id, ext, Text_exception, Exported) ]) + "Print the signature of the corresponding exception." + + let () = + reg_show_prim "show_module" + (fun env loc id lid -> + let rec accum_aliases md acc = + let acc = + Sig_module + ( id, + Mp_present, + { md with md_type = trim_signature md.md_type }, + Trec_not, + Exported ) + :: acc + in + match md.md_type with + | Mty_alias path -> + let md = Env.find_module path env in + accum_aliases md acc + | Mty_ident _ | Mty_signature _ | Mty_functor _ -> List.rev acc + in + let _, md = Env.lookup_module ~loc lid env in + accum_aliases md []) + "Print the signature of the corresponding module." + + let () = + reg_show_prim "show_module_type" + (fun env loc id lid -> + let _path, desc = Env.lookup_modtype ~loc lid env in + [ Sig_modtype (id, desc, Exported) ]) + "Print the signature of the corresponding module type." + + let () = + reg_show_prim "show_class" + (fun env loc id lid -> + let _path, desc = Env.lookup_class ~loc lid env in + [ Sig_class (id, desc, Trec_not, Exported) ]) + "Print the signature of the corresponding class." + + let () = + reg_show_prim "show_class_type" + (fun env loc id lid -> + let _path, desc = Env.lookup_cltype ~loc lid env in + [ Sig_class_type (id, desc, Trec_not, Exported) ]) + "Print the signature of the corresponding class type." + + let show env loc id lid = + let sg = + List.fold_left + (fun sg f -> try f env loc id lid @ sg with _ -> sg) + [] !all_show_funs + in + if sg = [] then raise Not_found else sg + + let () = + add_directive "show" + (Directive_ident (show_prim show !std_out)) + { + section = section_env; + doc = + "Print the signatures of components from any of the categories below."; + } + + let _ = + add_directive "trace" + (Directive_ident (dir_trace !std_out)) + { + section = section_trace; + doc = "All calls to the function named function-name will be traced."; + } + + let _ = + add_directive "untrace" + (Directive_ident (dir_untrace !std_out)) + { section = section_trace; doc = "Stop tracing the given function." } + + let _ = + add_directive "untrace_all" + (Directive_none (dir_untrace_all !std_out)) + { + section = section_trace; + doc = "Stop tracing all functions traced so far."; + } + + (* Control the printing of values *) + + let _ = + add_directive "print_depth" + (Directive_int (fun n -> max_printer_depth := n)) + { + section = section_print; + doc = "Limit the printing of values to a maximal depth of n."; + } + + let _ = + add_directive "print_length" + (Directive_int (fun n -> max_printer_steps := n)) + { + section = section_print; + doc = "Limit the number of value nodes printed to at most n."; + } + + (* Set various compiler flags *) + + let _ = + add_directive "labels" + (Directive_bool (fun b -> Clflags.classic := not b)) + { + section = section_options; + doc = "Choose whether to ignore labels in function types."; + } + + let _ = + add_directive "principal" + (Directive_bool (fun b -> Clflags.principal := b)) + { + section = section_options; + doc = "Make sure that all types are derived in a principal way."; + } + + let _ = + add_directive "rectypes" + (Directive_none (fun () -> Clflags.recursive_types := true)) + { + section = section_options; + doc = "Allow arbitrary recursive types during type-checking."; + } + + let _ = + add_directive "ppx" + (Directive_string (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx)) + { + section = section_options; + doc = + "After parsing, pipe the abstract syntax tree through the \ + preprocessor command."; + } + + let _ = + add_directive "warnings" + (Directive_string (parse_warnings !std_out false)) + { + section = section_options; + doc = "Enable or disable warnings according to the argument."; + } + + let _ = + add_directive "warn_error" + (Directive_string (parse_warnings !std_out true)) + { + section = section_options; + doc = "Treat as errors the warnings enabled by the argument."; + } + + (* #help directive *) + + let directive_sections () = + let sections = Hashtbl.create 10 in + let add_dir name dir = + let section, doc = + match Hashtbl.find directive_info_table name with + | { section; doc } -> (section, Some doc) + | exception Not_found -> ("Undocumented", None) + in + Hashtbl.replace sections section + ((name, dir, doc) + :: (try Hashtbl.find sections section with Not_found -> [])) + in + Hashtbl.iter add_dir directive_table; + let take_section section = + if not (Hashtbl.mem sections section) then (section, []) + else + let section_dirs = + Hashtbl.find sections section + |> List.sort (fun (n1, _, _) (n2, _, _) -> String.compare n1 n2) + in + Hashtbl.remove sections section; + (section, section_dirs) + in + let before, after = order_of_sections in + let sections_before = List.map take_section before in + let sections_after = List.map take_section after in + let sections_user = + Hashtbl.fold (fun section _ acc -> section :: acc) sections [] + |> List.sort String.compare |> List.map take_section + in + sections_before @ sections_user @ sections_after + + let print_directive ppf (name, directive, doc) = + let param = + match directive with + | Directive_none _ -> "" + | Directive_string _ -> " " + | Directive_int _ -> " " + | Directive_bool _ -> " " + | Directive_ident _ -> " " + in + match doc with + | None -> fprintf ppf "#%s%s@." name param + | Some doc -> + fprintf ppf "@[#%s%s@\n%a@]@." name param Format.pp_print_text + doc + + let print_section ppf (section, directives) = + if directives <> [] then ( + fprintf ppf "%30s%s@." "" section; + List.iter (print_directive ppf) directives; + fprintf ppf "@.") + + let print_directives ppf () = + List.iter (print_section ppf) (directive_sections ()) + + let _ = + add_directive "help" + (Directive_none (print_directives !std_out)) + { + section = section_general; + doc = + "Prints a list of all available directives, with corresponding \ + argument type if appropriate."; + } +end + +type evalenv = Format.formatter -> string -> unit + +let eval lb ppf (text : string) = + F.epr "Topmain.eval: \n"; + Topdirs.std_out := ppf; + (read_interactive_input := + fun buffer _ -> + Bytes.blit_string text 0 buffer 0 (String.length text); + Buffer.add_string phrase_buffer text; + (* Also populate the phrase buffer as new characters are added. *) + String.length text); + let snap = Btype.snapshot () in + try + F.epr "Topmain.eval: 1 reset@."; + Buffer.reset phrase_buffer; + (* Reset the phrase buffer, then flush the lexing buffer. *) + Lexing.flush_input lb; + (* calls read_interactive_input to fill buffer again *) + Location.reset (); + Warnings.reset_fatal (); + F.epr "Topmain.eval: 2 parse_toplevel_phrase@."; + let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + F.epr "Topmain.eval: 3 preprocess_phrase@."; + let phr = preprocess_phrase ppf phr in + F.epr "Topmain.eval: 4 Env.reset_cache_toplevel@."; + Env.reset_cache_toplevel (); + F.epr "Topmain.eval: 5 execute_phrase=%b@." (execute_phrase true ppf phr); + F.epr "Topmain.eval: 6 handle exceptions@." + with + | End_of_file -> + F.epr "Topmain.eval End_of_file exception\n"; + Btype.backtrack snap + | Sys.Break -> + F.epr "Topmain.eval Sys.Break exception\n"; + F.pf ppf "Interrupted.@."; + Btype.backtrack snap + | PPerror -> + F.epr "Topmain.eval PPerror exception\n"; + () + | x -> + F.epr "Topmain.eval unknown exception\n"; + Location.report_exception ppf x; + Btype.backtrack snap + +let preload_objects = ref [ (*"komm.cma"*) ] + +let init ppf = + F.epr "Topmain.init: \n"; + Topdirs.std_out := ppf; + Clflags.include_dirs := + List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs; + (* Topdirs.dir_directory ((Sys.getcwd ()) ^ "/topfind");*) + let extra_paths = + match Sys.getenv "OCAML_TOPLEVEL_PATH" with + | exception Not_found -> [] + | s -> Misc.split_path_contents s + in + Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs; + Compenv.readenv ppf Before_args; + Compenv.readenv ppf Before_link; + Compmisc.read_clflags_from_env (); + set_paths (); + (try + F.epr "Load_path.get_paths: @."; + List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ()); + let res = + List.for_all + (fun name -> + F.epr "Topdirs.load_file: name=%s@." name; + Topdirs.load_file ppf name) + (List.rev !preload_objects @ !Compenv.first_objfiles) + in + run_hooks Startup; + if not res then raise Exit + with Exit as x -> + Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n" + (Printexc.to_string x)); + Compmisc.init_path (); + Clflags.debug := true; + Location.formatter_for_warnings := ppf; + if not !Clflags.noversion then F.pf ppf "OCaml version %s@.@." Config.version; + (try initialize_toplevel_env () + with (Env.Error _ | Typetexp.Error _) as exn -> + Location.report_exception ppf exn; + raise Exit); + let lb = Lexing.from_function (fun b l -> !read_interactive_input b l) in + Location.init lb "//toplevel//"; + Location.input_name := "//toplevel//"; + Location.input_lexbuf := Some lb; + Location.input_phrase_buffer := Some phrase_buffer; + Sys.catch_break true; + run_hooks After_setup; + eval lb diff --git a/bin/topinf.mli b/bin/topinf.mli new file mode 100644 index 0000000..e1584f7 --- /dev/null +++ b/bin/topinf.mli @@ -0,0 +1,12 @@ +(* 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 print_toplevel_value_bindings : unit -> unit + +type evalenv = Format.formatter -> string -> unit + +val init : Format.formatter -> evalenv