[@@@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 (fun _ _ -> ())

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
        "@[<hv 0>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 _ -> " <str>"
      | Directive_int _ -> " <int>"
      | Directive_bool _ -> " <bool>"
      | Directive_ident _ -> " <ident>" in
    match doc with
    | None -> fprintf ppf "#%s%s@." name param
    | Some doc ->
        fprintf ppf "@[<hov 2>#%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 := eval_fun lb ;
  eval_fun lb
