[@@@ocaml.warning "-32"] (* most of this is copied from ocaml sources because it's not exported in a way i found useful: - toplevel/toploop.ml - toplevel/topdirs.ml - lambda/translmod.ml It's looking liek OCaml 4.13 will allow reducing this to hopefully nothing in the future *) module F = Fmt 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 ppf = ref Format.std_formatter let eval = ref None let getvalue name = try String.Map.find name !toplevel_value_bindings with Not_found -> fatal_error (name ^ " unbound at toplevel") let setvalue name v = toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings let print_toplevel_value_bindings ppf = String.Map.iter (fun k _ -> F.pf ppf "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 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 = try Ident.find_same id !aliased_idents with Not_found -> Ident.name id let toploop_getvalue 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 = 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 = 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 | _ -> ( 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 dir_use_silently ppf name = ignore (use_silently 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." } let _ = add_directive "use_silently" (Directive_string (dir_use_silently !std_out)) { section= section_run ; doc= "Usage is identical to #use but #use_silently supresses \ all toplevel definition output." } (* 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 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_fun lb ppf (text : string) = 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 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 () ; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in let phr = preprocess_phrase ppf phr in Env.reset_cache_toplevel () ; ignore (execute_phrase true ppf phr) 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 = 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 let res = List.for_all (fun 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 := Some (eval_fun lb) ; eval_fun lb