Imported Upstream version 8.8.2upstream/8.8.2

52 files changed, 1665 insertions, 14232 deletions

diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml
deleted file mode 100644
index 45c539e2..00000000
--- a/toplevel/assumptions.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* The following definitions are used by the function
-   [assumptions] which gives as an output the set of all
-   axioms and sections variables on which a given term depends
-   in a context (expectingly the Global context) *)
-
-(* Initial author: Arnaud Spiwack
-   Module-traversing code: Pierre Letouzey *)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Term
-open Declarations
-open Mod_subst
-open Globnames
-open Printer
-open Context.Named.Declaration
-
-(** For a constant c in a module sealed by an interface (M:T and
-    not M<:T), [Global.lookup_constant] may return a [constant_body]
-    without body. We fix this by looking in the implementation
-    of the module *)
-
-let modcache = ref (MPmap.empty : structure_body MPmap.t)
-
-let rec search_mod_label lab = function
-  | [] -> raise Not_found
-  | (l, SFBmodule mb) :: _ when Label.equal l lab -> mb
-  | _ :: fields -> search_mod_label lab fields
-
-let rec search_cst_label lab = function
-  | [] -> raise Not_found
-  | (l, SFBconst cb) :: _ when Label.equal l lab -> cb
-  | _ :: fields -> search_cst_label lab fields
-
-(* TODO: using [empty_delta_resolver] below is probably slightly incorrect. But:
-    a) I don't see currently what should be used instead
-    b) this shouldn't be critical for Print Assumption. At worse some
-       constants will have a canonical name which is non-canonical,
-       leading to failures in [Global.lookup_constant], but our own
-       [lookup_constant] should work.
-*)
-
-let rec fields_of_functor f subs mp0 args = function
-  |NoFunctor a -> f subs mp0 args a
-  |MoreFunctor (mbid,_,e) ->
-    match args with
-    | [] -> assert false (* we should only encounter applied functors *)
-    | mpa :: args ->
-      let subs = join (map_mbid mbid mpa empty_delta_resolver (*TODO*)) subs in
-      fields_of_functor f subs mp0 args e
-
-let rec lookup_module_in_impl mp =
-  try Global.lookup_module mp
-  with Not_found ->
-    (* The module we search might not be exported by its englobing module(s).
-       We access the upper layer, and then do a manual search *)
-    match mp with
-    | MPfile _ -> raise Not_found (* can happen if mp is an open module *)
-    | MPbound _ -> assert false
-    | MPdot (mp',lab') ->
-       let fields = memoize_fields_of_mp mp' in
-       search_mod_label lab' fields
-
-and memoize_fields_of_mp mp =
-  try MPmap.find mp !modcache
-  with Not_found ->
-    let l = fields_of_mp mp in
-    modcache := MPmap.add mp l !modcache;
-    l
-
-and fields_of_mp mp =
-  let mb = lookup_module_in_impl mp in
-  let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in
-  let subs =
-    if mp_eq inner_mp mp then subs
-    else add_mp inner_mp mp mb.mod_delta subs
-  in
-  Modops.subst_structure subs fields
-
-and fields_of_mb subs mb args = match mb.mod_expr with
-  |Algebraic expr -> fields_of_expression subs mb.mod_mp args expr
-  |Struct sign -> fields_of_signature subs mb.mod_mp args sign
-  |Abstract|FullStruct -> fields_of_signature subs mb.mod_mp args mb.mod_type
-
-(** The Abstract case above corresponds to [Declare Module] *)
-
-and fields_of_signature x =
-  fields_of_functor
-    (fun subs mp0 args struc ->
-      assert (List.is_empty args);
-      (struc, mp0, subs)) x
-
-and fields_of_expr subs mp0 args = function
-  |MEident mp ->
-    let mb = lookup_module_in_impl (subst_mp subs mp) in
-    fields_of_mb subs mb args
-  |MEapply (me1,mp2) -> fields_of_expr subs mp0 (mp2::args) me1
-  |MEwith _ -> assert false (* no 'with' in [mod_expr] *)
-
-and fields_of_expression x = fields_of_functor fields_of_expr x
-
-let lookup_constant_in_impl cst fallback =
-  try
-    let mp,dp,lab = repr_kn (canonical_con cst) in
-    let fields = memoize_fields_of_mp mp in
-    (* A module found this way is necessarily closed, in particular
-       our constant cannot be in an opened section : *)
-    search_cst_label lab fields
-  with Not_found ->
-    (* Either:
-       - The module part of the constant isn't registered yet :
-         we're still in it, so the [constant_body] found earlier
-         (if any) was a true axiom.
-       - The label has not been found in the structure. This is an error *)
-    match fallback with
-      | Some cb -> cb
-      | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst)
-
-let lookup_constant cst =
-  try
-    let cb = Global.lookup_constant cst in
-    if Declareops.constant_has_body cb then cb
-    else lookup_constant_in_impl cst (Some cb)
-  with Not_found -> lookup_constant_in_impl cst None
-
-(** Graph traversal of an object, collecting on the way the dependencies of
-    traversed objects *)
-
-let label_of = function
-  | ConstRef kn -> pi3 (repr_con kn)
-  | IndRef (kn,_)
-  | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn)
-  | VarRef id -> Label.of_id id
-
-let rec traverse current ctx accu t = match kind_of_term t with
-| Var id ->
-  let body () = Global.lookup_named id |> get_value in
-  traverse_object accu body (VarRef id)
-| Const (kn, _) ->
-  let body () = Global.body_of_constant_body (lookup_constant kn) in
-  traverse_object accu body (ConstRef kn)
-| Ind ((mind, _) as ind, _) ->
-  traverse_inductive accu mind (IndRef ind)
-| Construct (((mind, _), _) as cst, _) ->
-  traverse_inductive accu mind (ConstructRef cst)
-| Meta _ | Evar _ -> assert false
-| Case (_,oty,c,[||]) ->
-    (* non dependent match on an inductive with no constructors *)
-    begin match Constr.(kind oty, kind c) with
-    | Lambda(_,_,oty), Const (kn, _)
-      when Vars.noccurn 1 oty &&
-      not (Declareops.constant_has_body (lookup_constant kn)) ->
-        let body () = Global.body_of_constant_body (lookup_constant kn) in
-        traverse_object
-          ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn)
-    | _ ->
-        Termops.fold_constr_with_full_binders
-          Context.Rel.add (traverse current) ctx accu t
-    end
-| _ -> Termops.fold_constr_with_full_binders
-          Context.Rel.add (traverse current) ctx accu t
-
-and traverse_object ?inhabits (curr, data, ax2ty) body obj =
-  let data, ax2ty =
-    let already_in = Refmap_env.mem obj data in
-    match body () with
-    | None ->
-        let data =
-          if not already_in then Refmap_env.add obj Refset_env.empty data else data in
-        let ax2ty =
-          if Option.is_empty inhabits then ax2ty else
-          let ty = Option.get inhabits in
-          try let l = Refmap_env.find obj ax2ty in Refmap_env.add obj (ty::l) ax2ty 
-          with Not_found -> Refmap_env.add obj [ty] ax2ty in
-        data, ax2ty
-    | Some body ->
-      if already_in then data, ax2ty else
-      let contents,data,ax2ty =
-        traverse (label_of obj) Context.Rel.empty
-                 (Refset_env.empty,data,ax2ty) body in
-      Refmap_env.add obj contents data, ax2ty
-  in
-  (Refset_env.add obj curr, data, ax2ty)
-
-(** Collects the references occurring in the declaration of mutual inductive
-    definitions. All the constructors and names of a mutual inductive
-    definition share exactly the same dependencies. Also, there is no explicit
-    dependency between mutually defined inductives and constructors. *)
-and traverse_inductive (curr, data, ax2ty) mind obj =
-  let firstind_ref = (IndRef (mind, 0)) in
-  let label = label_of obj in
-  let data, ax2ty =
-   (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data
-      where I_0, I_1, ... are in the same mutual definition and c_ij
-      are all their constructors. *)
-   if Refmap_env.mem firstind_ref data then data, ax2ty else
-     let mib = Global.lookup_mind mind in
-     (* Collects references of parameters *)
-     let param_ctx = mib.mind_params_ctxt in
-     let nparam = List.length param_ctx in
-     let accu =
-       traverse_context label Context.Rel.empty
-                        (Refset_env.empty, data, ax2ty) param_ctx
-     in
-     (* Build the context of all arities *)
-     let arities_ctx =
-       let global_env = Global.env () in
-       Array.fold_left (fun accu oib ->
-          let pspecif = Univ.in_punivs (mib, oib) in
-          let ind_type = Inductive.type_of_inductive global_env pspecif in
-          let ind_name = Name oib.mind_typename in
-          Context.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu)
-          Context.Rel.empty mib.mind_packets
-     in
-     (* For each inductive, collects references in their arity and in the type
-        of constructors*)
-     let (contents, data, ax2ty) = Array.fold_left (fun accu oib ->
-         let arity_wo_param =
-           List.rev (List.skipn nparam (List.rev oib.mind_arity_ctxt))
-         in
-         let accu =
-           traverse_context
-             label param_ctx accu arity_wo_param
-         in
-         Array.fold_left (fun accu cst_typ ->
-            let param_ctx, cst_typ_wo_param = Term.decompose_prod_n_assum nparam cst_typ in
-            let ctx = Context.(Rel.fold_outside Context.Rel.add ~init:arities_ctx param_ctx) in
-            traverse label ctx accu cst_typ_wo_param)
-          accu oib.mind_user_lc)
-       accu mib.mind_packets
-     in
-     (* Maps all these dependencies to inductives and constructors*)
-     let data = Array.fold_left_i (fun n data oib ->
-       let ind = (mind, n) in
-       let data = Refmap_env.add (IndRef ind) contents data in
-       Array.fold_left_i (fun k data _ ->
-         Refmap_env.add (ConstructRef (ind, k+1)) contents data
-       ) data oib.mind_consnames) data mib.mind_packets
-     in
-     data, ax2ty
-  in
-  (Refset_env.add obj curr, data, ax2ty)
-
-(** Collects references in a rel_context. *)
-and traverse_context current ctx accu ctxt =
-  snd (Context.Rel.fold_outside (fun decl (ctx, accu) ->
-    match decl with
-     | Context.Rel.Declaration.LocalDef (_,c,t) ->
-          let accu = traverse current ctx (traverse current ctx accu t) c in
-          let ctx = Context.Rel.add decl ctx in
-          ctx, accu
-     | Context.Rel.Declaration.LocalAssum (_,t) ->
-          let accu = traverse current ctx accu t in
-          let ctx = Context.Rel.add decl ctx in
-           ctx, accu) ctxt ~init:(ctx, accu))
-
-let traverse current t =
-  let () = modcache := MPmap.empty in
-  traverse current Context.Rel.empty (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t
-
-(** Hopefully bullet-proof function to recover the type of a constant. It just
-    ignores all the universe stuff. There are many issues that can arise when
-    considering terms out of any valid environment, so use with caution. *)
-let type_of_constant cb = match cb.Declarations.const_type with
-| Declarations.RegularArity ty -> ty
-| Declarations.TemplateArity (ctx, arity) ->
-  Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level)
-
-let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t =
-  let (idts, knst) = st in
-  (** Only keep the transitive dependencies *)
-  let (_, graph, ax2ty) = traverse (label_of gr) t in
-  let fold obj _ accu = match obj with
-  | VarRef id ->
-    let decl = Global.lookup_named id in
-    if is_local_assum decl then
-      let t = Context.Named.Declaration.get_type decl in
-      ContextObjectMap.add (Variable id) t accu
-    else accu
-  | ConstRef kn ->
-      let cb = lookup_constant kn in
-      let accu =
-        if cb.const_typing_flags.check_guarded then accu
-        else
-          let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
-          ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu
-      in
-    if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then
-      let t = type_of_constant cb in
-      let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
-      ContextObjectMap.add (Axiom (Constant kn,l)) t accu
-    else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then
-      let t = type_of_constant cb in
-      ContextObjectMap.add (Opaque kn) t accu
-    else if add_transparent then
-      let t = type_of_constant cb in
-      ContextObjectMap.add (Transparent kn) t accu
-    else
-      accu
-  | IndRef (m,_) | ConstructRef ((m,_),_) ->
-      let mind = Global.lookup_mind m in
-      if mind.mind_typing_flags.check_guarded then
-        accu
-      else
-        let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
-        ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu
-  in
-  Refmap_env.fold fold graph ContextObjectMap.empty
diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli
deleted file mode 100644
index 07267578..00000000
--- a/toplevel/assumptions.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-open Globnames
-open Printer
-
-(** Collects all the objects on which a term directly relies, bypassing kernel
-    opacity, together with the recursive dependence DAG of objects.
-
-    WARNING: some terms may not make sense in the environment, because they are
-    sealed inside opaque modules. Do not try to do anything fancy with those
-    terms apart from printing them, otherwise demons may fly out of your nose.
-*)
-val traverse :
-  Label.t -> constr ->
-    (Refset_env.t * Refset_env.t Refmap_env.t *
-     (label * Context.Rel.t * types) list Refmap_env.t)
-
-(** Collects all the assumptions (optionally including opaque definitions)
-   on which a term relies (together with their type). The above warning of
-   {!traverse} also applies. *)
-val assumptions :
-  ?add_opaque:bool -> ?add_transparent:bool -> transparent_state ->
-     global_reference -> constr -> Term.types ContextObjectMap.t
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
deleted file mode 100644
index 0561fc4b..00000000
--- a/toplevel/auto_ind_decl.ml
+++ /dev/null
@@ -1,960 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* This file is about the automatic generation of schemes about
-   decidable equality, created by Vincent Siles, Oct 2007 *)
-
-open Tacmach
-open CErrors
-open Util
-open Pp
-open Term
-open Vars
-open Termops
-open Declarations
-open Names
-open Globnames
-open Nameops
-open Inductiveops
-open Tactics
-open Ind_tables
-open Misctypes
-open Proofview.Notations
-open Context.Rel.Declaration
-
-let out_punivs = Univ.out_punivs
-
-(**********************************************************************)
-(* Generic synthesis of boolean equality *)
-
-let quick_chop n l =
-  let rec kick_last = function
-    | t::[] -> []
-    | t::q -> t::(kick_last q)
-    | [] -> failwith "kick_last"
-and aux = function
-    | (0,l') -> l'
-    | (n,h::t) -> aux (n-1,t)
-    | _ -> failwith "quick_chop"
-  in
-  if n > (List.length l) then failwith "quick_chop args"
-  else kick_last (aux (n,l) )
-
-let deconstruct_type t =
-  let l,r = decompose_prod t in
-  (List.rev_map snd l)@[r]
-
-exception EqNotFound of inductive * inductive
-exception EqUnknown of string
-exception UndefinedCst of string
-exception InductiveWithProduct
-exception InductiveWithSort
-exception ParameterWithoutEquality of global_reference
-exception NonSingletonProp of inductive
-exception DecidabilityMutualNotSupported
-
-let dl = Loc.ghost
-
-let constr_of_global g = lazy (Universes.constr_of_global g)
-
-(* Some pre declaration of constant we are going to use *)
-let bb = constr_of_global Coqlib.glob_bool
-
-let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop
-
-let andb_true_intro = fun _ ->
-    (Coqlib.build_bool_type()).Coqlib.andb_true_intro
-
-let tt = constr_of_global Coqlib.glob_true
-
-let ff = constr_of_global Coqlib.glob_false
-
-let eq = constr_of_global Coqlib.glob_eq
-
-let sumbool = Coqlib.build_coq_sumbool
-
-let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb
-
-let induct_on c = induction false None c None None
-
-let destruct_on c = destruct false None c None None
-
-let destruct_on_using c id =
-  destruct false None c
-    (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous];
-               [dl,IntroNaming (IntroIdentifier id)]]))
-    None
-
-let destruct_on_as c l =
-  destruct false None c (Some (dl,l)) None
-
-(* reconstruct the inductive with the correct deBruijn indexes *)
-let mkFullInd (ind,u) n =
-  let mib = Global.lookup_mind (fst ind) in
-  let nparams = mib.mind_nparams in
-  let nparrec = mib.mind_nparams_rec in
-  (* params context divided *)
-  let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  if nparrec > 0
-    then mkApp (mkIndU (ind,u),
-      Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec))
-    else mkIndU (ind,u)
-
-let check_bool_is_defined () =
-  try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in ()
-  with e when CErrors.noncritical e -> raise (UndefinedCst "bool")
-
-let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
-
-let build_beq_scheme mode kn =
-  check_bool_is_defined ();
-  (* fetching global env *)
-  let env = Global.env() in
-  (* fetching the mutual inductive body *)
-  let mib = Global.lookup_mind kn in
-  (* number of inductives in the mutual *)
-  let nb_ind = Array.length mib.mind_packets in
-  (* number of params in the type *)
-  let nparams = mib.mind_nparams in
-  let nparrec = mib.mind_nparams_rec in
-  (* params context divided *)
-  let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  (* predef coq's boolean type *)
-  (* rec name *)
-  let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^
-                    "_eqrec"
-  in
-  (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *)
-  let create_input c =
-    let myArrow u v = mkArrow u (lift 1 v)
-    and eqName = function
-        | Name s -> Id.of_string ("eq_"^(Id.to_string s))
-        | Anonymous -> Id.of_string "eq_A"
-    in
-    let ext_rel_list = Context.Rel.to_extended_list 0 lnamesparrec in
-      let lift_cnt = ref 0 in
-      let eqs_typ = List.map (fun aa ->
-                                let a = lift !lift_cnt aa in
-                                  incr lift_cnt;
-                                  myArrow a (myArrow a (Lazy.force bb))
-                             ) ext_rel_list in
-
-        let eq_input = List.fold_left2
-          ( fun a b decl -> (* mkLambda(n,b,a) ) *)
-                (* here I leave the Naming thingy so that the type of
-                  the function is more readable for the user *)
-                mkNamedLambda (eqName (get_name decl)) b a )
-                c (List.rev eqs_typ) lnamesparrec
-       in
-        List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *)
-          (* Same here , hoping the auto renaming will do something good ;)  *)
-          mkNamedLambda
-                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
-                (get_type decl)  a) eq_input lnamesparrec
- in
- let make_one_eq cur =
-  let u = Univ.Instance.empty in
-  let ind = (kn,cur),u (* FIXME *) in
-  (* current inductive we are working on *)
-  let cur_packet = mib.mind_packets.(snd (fst ind)) in
-  (* Inductive toto : [rettyp] := *)
-  let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in
-  (* split rettyp in a list without the non rec params and the last ->
-  e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *)
-  let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in
-    (* give a type A, this function tries to find the equality on A declared
-       previously *)
-    (*  nlist = the number of args (A , B , ... )
-        eqA   = the deBruijn index of the first eq param
-        ndx   = how much to translate due to the 2nd Case
-    *)
-    let compute_A_equality rel_list nlist eqA ndx t =
-      let lifti = ndx in
-      let rec aux c =
-	let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
-	match kind_of_term c with
-        | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants
-        | Var x ->
-          let eid = id_of_string ("eq_"^(string_of_id x)) in
-          let () =
-            try ignore (Environ.lookup_named eid env)
-            with Not_found -> raise (ParameterWithoutEquality (VarRef x))
-          in
-          mkVar eid, Safe_typing.empty_private_constants
-        | Cast (x,_,_) -> aux (applist (x,a))
-        | App _ -> assert false
-        | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> 
-            if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants
-            else begin
-              try
-                let eq, eff =
-                  let c, eff = find_scheme ~mode (!beq_scheme_kind_aux()) (kn',i) in
-                  mkConst c, eff in
-                let eqa, eff =
-                  let eqa, effs = List.split (List.map aux a) in
-                  Array.of_list eqa,
-                  List.fold_left Safe_typing.concat_private eff (List.rev effs)
-                  in
-                let args =
-                  Array.append 
-                    (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in
-                if Int.equal (Array.length args) 0 then eq, eff
-                else mkApp (eq, args), eff
-              with Not_found -> raise(EqNotFound (ind', fst ind))
-            end
-        | Sort _  -> raise InductiveWithSort
-        | Prod _ -> raise InductiveWithProduct
-        | Lambda _-> raise (EqUnknown "Lambda")
-        | LetIn _ -> raise (EqUnknown "LetIn")
-        | Const kn ->
-	    (match Environ.constant_opt_value_in env kn with
-	      | None -> raise (ParameterWithoutEquality (ConstRef (fst kn)))
-	      | Some c -> aux (applist (c,a)))
-        | Proj _ -> raise (EqUnknown "Proj")
-        | Construct _ -> raise (EqUnknown "Construct")
-        | Case _ -> raise (EqUnknown "Case")
-        | CoFix _ -> raise (EqUnknown "CoFix")
-        | Fix _   -> raise (EqUnknown "Fix")
-        | Meta _  -> raise (EqUnknown "Meta")
-        | Evar _  -> raise (EqUnknown "Evar")
-    in
-      aux t
-  in
-  (* construct the predicate for the Case part*)
-  let do_predicate rel_list n =
-     List.fold_left (fun a b -> mkLambda(Anonymous,b,a))
-      (mkLambda (Anonymous,
-                 mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1),
-                 (Lazy.force bb)))
-      (List.rev rettyp_l) in
-  (* make_one_eq *)
-  (* do the [| C1 ... =>  match Y with ... end
-               ...
-               Cn => match Y with ... end |]  part *)
-    let ci = make_case_info env (fst ind) MatchStyle in
-    let constrs n = get_constructors env (make_ind_family (ind,
-      Context.Rel.to_extended_list (n+nb_ind-1) mib.mind_params_ctxt)) in
-    let constrsi = constrs (3+nparrec) in
-    let n = Array.length constrsi in
-    let ar = Array.make n (Lazy.force ff) in
-    let eff = ref Safe_typing.empty_private_constants in
-	for i=0 to n-1 do
-	  let nb_cstr_args = List.length constrsi.(i).cs_args in
-	  let ar2 = Array.make n (Lazy.force ff) in
-          let constrsj = constrs (3+nparrec+nb_cstr_args) in
-	    for j=0 to n-1 do
-	      if Int.equal i j then
-		ar2.(j) <- let cc = (match nb_cstr_args with
-                    | 0 -> Lazy.force tt
-                    | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in
-                      for ndx = 0 to nb_cstr_args-1 do
-                        let cc = get_type (List.nth constrsi.(i).cs_args ndx) in
-                          let eqA, eff' = compute_A_equality rel_list
-                                          nparrec
-                                          (nparrec+3+2*nb_cstr_args)
-                                          (nb_cstr_args+ndx+1)
-                                          cc
-                          in
-                          eff := Safe_typing.concat_private eff' !eff;
-                          Array.set eqs ndx
-                              (mkApp (eqA,
-                                [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|]
-                              ))
-                      done;
-                      Array.fold_left
-                          (fun a b -> mkApp (andb(),[|b;a|]))
-                          (eqs.(0))
-                          (Array.sub eqs 1 (nb_cstr_args - 1))
-                  )
-   		  in
-		    (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc
-                    (constrsj.(j).cs_args)
-		)
-	      else ar2.(j) <- (List.fold_left (fun a decl ->
-			mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) )
-	    done;
-
-	  ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a))
-			(mkCase (ci,do_predicate rel_list nb_cstr_args,
-				  mkVar (Id.of_string "Y") ,ar2))
-			 (constrsi.(i).cs_args))
-	done;
-        mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1))  (
-          mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2))  (
- 	    mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))),
-        !eff
-    in (* build_beq_scheme *)
-    let names = Array.make nb_ind Anonymous and
-        types = Array.make nb_ind mkSet and
-        cores = Array.make nb_ind mkSet in
-    let eff = ref Safe_typing.empty_private_constants in
-    let u = Univ.Instance.empty in
-    for i=0 to (nb_ind-1) do
-        names.(i) <- Name (Id.of_string (rec_name i));
-	types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0)
-                     (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb));
-        let c, eff' = make_one_eq i in
-        cores.(i) <- c;
-        eff := Safe_typing.concat_private eff' !eff
-    done;
-      (Array.init nb_ind (fun i ->
-      let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in
-	if not (Sorts.List.mem InSet kelim) then
-	  raise (NonSingletonProp (kn,i));
-        let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in
-        create_input fix),
-       Evd.make_evar_universe_context (Global.env ()) None),
-      !eff
-
-let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme
-
-let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind
-
-(* This function tryies to get the [inductive] between a constr
-  the constr should be Ind i or App(Ind i,[|args|])
-*)
-let destruct_ind c =
-    try let u,v =  destApp c in
-          let indc = destInd u in
-            indc,v
-    with DestKO -> let indc = destInd c in
-            indc,[||]
-
-(*
-  In the following, avoid is the list of names to avoid.
-  If the args of the Inductive type are A1 ... An
-  then avoid should be
- [| lb_An ... lb _A1  (resp. bl_An ... bl_A1)
-    eq_An .... eq_A1 An ... A1 |]
-so from Ai we can find the the correct eq_Ai bl_ai or lb_ai
-*)
-(* used in the leib -> bool side*)
-let do_replace_lb mode lb_scheme_key aavoid narg p q =
-  let avoid = Array.of_list aavoid in
-  let do_arg v offset =
-  try
-    let x = narg*offset in
-    let s = destVar v in
-    let n = Array.length avoid in
-    let rec find i =
-      if Id.equal avoid.(n-i) s then avoid.(n-i-x)
-      else (if i<n then find (i+1)
-            else errorlabstrm "AutoIndDecl.do_replace_lb"
-                   (str "Var " ++ pr_id s ++ str " seems unknown.")
-      )
-    in mkVar (find 1)
-  with e when CErrors.noncritical e ->
-      (* if this happen then the args have to be already declared as a
-              Parameter*)
-      (
-        let mp,dir,lbl = repr_con (fst (destConst v)) in
-          mkConst (make_con mp dir (mk_label (
-          if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
-                       else ((Label.to_string lbl)^"_lb")
-        )))
-      )
-  in
-  Proofview.Goal.nf_enter { enter = begin fun gl ->
-    let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in
-    let u,v = destruct_ind type_of_pq
-    in let lb_type_of_p =
-        try
-          let c, eff = find_scheme ~mode lb_scheme_key (out_punivs u) (*FIXME*) in
-          Proofview.tclUNIT (mkConst c, eff)
-        with Not_found ->
-          (* spiwack: the format of this error message should probably
-	              be improved. *)
-          let err_msg =
-	    (str "Leibniz->boolean:" ++
-             str "You have to declare the" ++
-	     str "decidability over " ++
-	     Printer.pr_constr type_of_pq ++
-	     str " first.")
-          in
-          Tacticals.New.tclZEROMSG err_msg
-       in
-       lb_type_of_p >>= fun (lb_type_of_p,eff) ->
-       let lb_args = Array.append (Array.append
-                          (Array.map (fun x -> x) v)
-                          (Array.map (fun x -> do_arg x 1) v))
-                          (Array.map (fun x -> do_arg x 2) v)
-        in let app =  if Array.equal eq_constr lb_args [||]
-                       then lb_type_of_p else mkApp (lb_type_of_p,lb_args)
-           in
-           Tacticals.New.tclTHENLIST [
-             Proofview.tclEFFECTS eff;
-             Equality.replace p q ; apply app ; Auto.default_auto]
-  end }
-
-(* used in the bool -> leib side *)
-let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
-  let avoid = Array.of_list aavoid in
-  let do_arg v offset =
-  try
-    let x = narg*offset in
-    let s = destVar v in
-    let n = Array.length avoid in
-    let rec find i =
-      if Id.equal avoid.(n-i) s then avoid.(n-i-x)
-      else (if i<n then find (i+1)
-            else errorlabstrm "AutoIndDecl.do_replace_bl"
-                   (str "Var " ++ pr_id s ++ str " seems unknown.")
-      )
-    in mkVar (find 1)
-  with e when CErrors.noncritical e ->
-      (* if this happen then the args have to be already declared as a
-         Parameter*)
-      (
-        let mp,dir,lbl = repr_con (fst (destConst v)) in
-          mkConst (make_con mp dir (mk_label (
-          if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
-                       else ((Label.to_string lbl)^"_bl")
-        )))
-      )
-  in
-
-  let rec aux l1 l2 =
-    match (l1,l2) with
-    | (t1::q1,t2::q2) ->
-        Proofview.Goal.enter { enter = begin fun gl ->
-        let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in
-        if eq_constr t1 t2 then aux q1 q2
-        else (
-          let u,v = try  destruct_ind tt1
-          (* trick so that the good sequence is returned*)
-                with e when CErrors.noncritical e -> indu,[||]
-          in if eq_ind (fst u) ind
-             then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ]
-             else (
-               let bl_t1, eff =
-               try 
-                 let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in
-                 mkConst c, eff
-               with Not_found ->
-		 (* spiwack: the format of this error message should probably
-	                     be improved. *)
-		 let err_msg = string_of_ppcmds
-	                                (str "boolean->Leibniz:" ++
-                                         str "You have to declare the" ++
-			   	         str "decidability over " ++
-				         Printer.pr_constr tt1 ++
-				         str " first.")
-		 in
-		 error err_msg
-               in let bl_args =
-                        Array.append (Array.append
-                          (Array.map (fun x -> x) v)
-                          (Array.map (fun x -> do_arg x 1) v))
-                          (Array.map (fun x -> do_arg x 2) v )
-                in
-                let app =  if Array.equal eq_constr bl_args [||]
-                           then bl_t1 else mkApp (bl_t1,bl_args)
-                in
-                Tacticals.New.tclTHENLIST [
-                  Proofview.tclEFFECTS eff;
-                  Equality.replace_by t1 t2
-                    (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ;
-                  aux q1 q2 ]
-              )
-        )
-        end }
-    | ([],[]) -> Proofview.tclUNIT ()
-    | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.")
-  in
-  begin try Proofview.tclUNIT (destApp lft)
-    with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.")
-  end >>= fun (ind1,ca1) ->
-  begin try Proofview.tclUNIT (destApp rgt)
-    with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.")
-  end >>= fun (ind2,ca2) ->
-  begin try Proofview.tclUNIT (out_punivs (destInd ind1))
-    with DestKO ->
-      begin try Proofview.tclUNIT (fst (fst (destConstruct ind1)))
-        with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.")
-      end
-  end >>= fun (sp1,i1) ->
-  begin try Proofview.tclUNIT (out_punivs (destInd ind2))
-    with DestKO ->
-      begin try Proofview.tclUNIT (fst (fst (destConstruct ind2)))
-        with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.")
-      end
-  end >>= fun (sp2,i2) ->
-  if not (eq_mind sp1 sp2) || not (Int.equal i1 i2)
-  then Tacticals.New.tclZEROMSG (str "Eq should be on the same type")
-  else aux (Array.to_list ca1) (Array.to_list ca2)
-
-(*
-  create, from a list of ids [i1,i2,...,in] the list
-  [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al  )]
-*)
-let list_id l = List.fold_left ( fun a decl -> let s' =
-      match get_name decl with
-        Name s -> Id.to_string s
-      | Anonymous -> "A" in
-          (Id.of_string s',Id.of_string ("eq_"^s'),
-              Id.of_string (s'^"_bl"),
-              Id.of_string (s'^"_lb"))
-            ::a
-    ) [] l
-(*
-  build the right eq_I A B.. N eq_A .. eq_N
-*)
-let eqI ind l =
-  let list_id = list_id l in
-  let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@
-                           (List.map (fun (_,seq,_,_)-> mkVar seq) list_id ))
-  and e, eff = 
-    try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff 
-    with Not_found -> errorlabstrm "AutoIndDecl.eqI"
-      (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed.");
-  in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff
-
-(**********************************************************************)
-(* Boolean->Leibniz *)
-
-let compute_bl_goal ind lnamesparrec nparrec =
-  let eqI, eff = eqI ind lnamesparrec in
-  let list_id = list_id lnamesparrec in
-  let create_input c =
-    let x = Id.of_string "x" and
-        y = Id.of_string "y" in
-      let bl_typ = List.map (fun (s,seq,_,_) ->
-        mkNamedProd x (mkVar s) (
-            mkNamedProd y (mkVar s) (
-              mkArrow
-               ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|]))
-               ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|]))
-          ))
-        ) list_id in
-      let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
-        mkNamedProd sbl b a
-      ) c (List.rev list_id) (List.rev bl_typ) in
-      let eqs_typ = List.map (fun (s,_,_,_) ->
-          mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb)))
-          ) list_id in
-      let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
-        mkNamedProd seq b a
-      ) bl_input (List.rev list_id) (List.rev eqs_typ) in
-      List.fold_left (fun a decl -> mkNamedProd
-                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
-                (get_type decl) a) eq_input lnamesparrec
-    in
-      let n = Id.of_string "x" and
-          m = Id.of_string "y" in
-      let u = Univ.Instance.empty in
-     create_input (
-        mkNamedProd n (mkFullInd (ind,u) nparrec) (
-          mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
-            mkArrow
-              (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|]))
-              (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|]))
-        ))), eff
-
-let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
-  let list_id = list_id lnamesparrec in
-  let avoid = ref [] in
-      let first_intros =
-        ( List.map (fun (s,_,_,_) -> s ) list_id ) @
-        ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @
-        ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id )
-      in
-      let fresh_id s gl =
-        Tacmach.New.of_old begin fun gsig ->
-          let fresh = fresh_id (!avoid) s gsig in
-          avoid := fresh::(!avoid); fresh
-        end gl
-      in
-      Proofview.Goal.nf_enter { enter = begin fun gl ->
-      let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
-      let freshn = fresh_id (Id.of_string "x") gl in
-      let freshm = fresh_id (Id.of_string "y") gl in
-      let freshz = fresh_id (Id.of_string "Z") gl in
-  (* try with *)
-      Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
-                     intro_using freshn ;
-                     induct_on (mkVar freshn);
-                     intro_using freshm;
-                     destruct_on (mkVar freshm);
-                     intro_using freshz;
-                     intros;
-                     Tacticals.New.tclTRY (
-                      Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
-                     );
-                     simpl_in_hyp (freshz,Locus.InHyp);
-(*
-repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
-*)
-                    Tacticals.New.tclREPEAT (
-                      Tacticals.New.tclTHENLIST [
-                         Simple.apply_in freshz (andb_prop());
-                         Proofview.Goal.nf_enter { enter = begin fun gl ->
-                           let fresht = fresh_id (Id.of_string "Z") gl in
-                            destruct_on_as (mkVar freshz)
-                                  (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht);
-                                    dl,IntroNaming (IntroIdentifier freshz)]])
-                         end }
-                        ]);
-(*
-  Ci a1 ... an = Ci b1 ... bn
- replace bi with ai; auto || replace bi with ai by  apply typeofbi_prod ; auto
-*)
-                      Proofview.Goal.nf_enter { enter = begin fun gls ->
-                        let gl = Proofview.Goal.concl gls in
-                        match (kind_of_term gl) with
-                        | App (c,ca) -> (
-                          match (kind_of_term c) with
-                          | Ind (indeq, u) ->
-                              if eq_gr (IndRef indeq) Coqlib.glob_eq
-                              then
-                                Tacticals.New.tclTHEN
-                                  (do_replace_bl mode bl_scheme_key ind
-				     (!avoid)
-                                     nparrec (ca.(2))
-                                     (ca.(1)))
-                                  Auto.default_auto
-                              else
-                                Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
-                          | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.")
-                        )
-                        | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
-                      end }
-
-                    ]
-      end }
-
-let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
-
-let side_effect_of_mode = function
-  | Declare.UserAutomaticRequest -> false
-  | Declare.InternalTacticRequest -> true
-  | Declare.UserIndividualRequest -> false
-
-let make_bl_scheme mode mind =
-  let mib = Global.lookup_mind mind in
-  if not (Int.equal (Array.length mib.mind_packets) 1) then
-    errorlabstrm ""
-      (str "Automatic building of boolean->Leibniz lemmas not supported");
-  let ind = (mind,0) in
-  let nparams = mib.mind_nparams in
-  let nparrec = mib.mind_nparams_rec in
-  let lnonparrec,lnamesparrec = (* TODO subst *)
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in
-  let ctx = Evd.make_evar_universe_context (Global.env ()) None in
-  let side_eff = side_effect_of_mode mode in
-  let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal
-    (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec)
-  in
-  ([|ans|], ctx), eff
-
-let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme
-
-let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind
-
-(**********************************************************************)
-(* Leibniz->Boolean *)
-
-let compute_lb_goal ind lnamesparrec nparrec =
-  let list_id = list_id lnamesparrec in
-  let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
-  let eqI, eff = eqI ind lnamesparrec in
-    let create_input c =
-      let x = Id.of_string "x" and
-          y = Id.of_string "y" in
-      let lb_typ = List.map (fun (s,seq,_,_) ->
-        mkNamedProd x (mkVar s) (
-            mkNamedProd y (mkVar s) (
-              mkArrow
-               ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
-               ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
-          ))
-        ) list_id in
-      let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
-        mkNamedProd slb b a
-      ) c (List.rev list_id) (List.rev lb_typ) in
-      let eqs_typ = List.map (fun (s,_,_,_) ->
-          mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
-          ) list_id in
-      let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
-        mkNamedProd seq b a
-      ) lb_input (List.rev list_id) (List.rev eqs_typ) in
-      List.fold_left (fun a decl -> mkNamedProd
-                (match (get_name decl) with Name s -> s | Anonymous ->  Id.of_string "A")
-                (get_type decl)  a) eq_input lnamesparrec
-    in
-      let n = Id.of_string "x" and
-          m = Id.of_string "y" in
-      let u = Univ.Instance.empty in
-      create_input (
-        mkNamedProd n (mkFullInd (ind,u) nparrec) (
-          mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
-            mkArrow
-              (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|]))
-              (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
-        ))), eff
-
-let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
-  let list_id = list_id lnamesparrec in
-    let avoid = ref [] in
-      let first_intros =
-        ( List.map (fun (s,_,_,_) -> s ) list_id ) @
-        ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
-        ( List.map (fun (_,_,_,slb) -> slb) list_id )
-      in
-      let fresh_id s gl =
-        Tacmach.New.of_old begin fun gsig ->
-          let fresh = fresh_id (!avoid) s gsig in
-          avoid := fresh::(!avoid); fresh
-        end gl
-      in
-      Proofview.Goal.nf_enter { enter = begin fun gl ->
-      let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
-      let freshn = fresh_id (Id.of_string "x") gl in
-      let freshm = fresh_id (Id.of_string "y") gl in
-      let freshz = fresh_id (Id.of_string "Z") gl in
-  (* try with *)
-      Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
-                     intro_using freshn ;
-                     induct_on (mkVar freshn);
-                     intro_using freshm;
-                     destruct_on (mkVar freshm);
-                     intro_using freshz;
-                     intros;
-                     Tacticals.New.tclTRY (
-                      Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
-                     );
-                     Equality.inj None false None (mkVar freshz,NoBindings);
-		     intros; simpl_in_concl;
-                     Auto.default_auto;
-                     Tacticals.New.tclREPEAT (
-                      Tacticals.New.tclTHENLIST [apply (andb_true_intro());
-                                  simplest_split ;Auto.default_auto ]
-                      );
-                      Proofview.Goal.nf_enter { enter = begin fun gls ->
-                        let gl = Proofview.Goal.concl gls in
-                        (* assume the goal to be eq (eq_type ...) = true *)
-                        match (kind_of_term gl) with
-                        | App(c,ca) -> (match (kind_of_term ca.(1)) with
-                          | App(c',ca') ->
-                              let n = Array.length ca' in
-                              do_replace_lb mode lb_scheme_key
-				(!avoid)
-                                nparrec
-                                ca'.(n-2) ca'.(n-1)
-                          | _ ->
-                              Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
-                        )
-                        | _ ->
-                            Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
-                      end }
-                    ]
-      end }
-
-let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
-
-let make_lb_scheme mode mind =
-  let mib = Global.lookup_mind mind in
-  if not (Int.equal (Array.length mib.mind_packets) 1) then
-    errorlabstrm ""
-      (str "Automatic building of Leibniz->boolean lemmas not supported");
-  let ind = (mind,0) in
-  let nparams = mib.mind_nparams in
-  let nparrec = mib.mind_nparams_rec in
-  let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in
-  let ctx = Evd.make_evar_universe_context (Global.env ()) None in
-  let side_eff = side_effect_of_mode mode in
-  let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal
-    (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)
-  in
-  ([|ans|], ctx), eff
-
-let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme
-
-let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind
-
-(**********************************************************************)
-(* Decidable equality *)
-
-let check_not_is_defined () =
-  try ignore (Coqlib.build_coq_not ())
-  with e when CErrors.noncritical e -> raise (UndefinedCst "not")
-
-(* {n=m}+{n<>m}  part  *)
-let compute_dec_goal ind lnamesparrec nparrec =
-  check_not_is_defined ();
-  let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
-  let list_id = list_id lnamesparrec in
-    let create_input c =
-      let x = Id.of_string "x" and
-          y = Id.of_string "y" in
-      let lb_typ = List.map (fun (s,seq,_,_) ->
-        mkNamedProd x (mkVar s) (
-            mkNamedProd y (mkVar s) (
-              mkArrow
-               ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
-               ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
-          ))
-        ) list_id in
-      let bl_typ = List.map (fun (s,seq,_,_) ->
-        mkNamedProd x (mkVar s) (
-            mkNamedProd y (mkVar s) (
-              mkArrow
-               ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
-               ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
-          ))
-        ) list_id in
-
-      let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
-        mkNamedProd slb b a
-      ) c (List.rev list_id) (List.rev lb_typ) in
-      let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
-        mkNamedProd sbl b a
-      ) lb_input (List.rev list_id) (List.rev bl_typ) in
-
-      let eqs_typ = List.map (fun (s,_,_,_) ->
-          mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
-          ) list_id in
-      let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
-        mkNamedProd seq b a
-      ) bl_input (List.rev list_id) (List.rev eqs_typ) in
-      List.fold_left (fun a decl -> mkNamedProd
-                (match get_name decl with Name s -> s | Anonymous ->  Id.of_string "A")
-                (get_type decl) a) eq_input lnamesparrec
-    in
-      let n = Id.of_string "x" and
-          m = Id.of_string "y" in
-        let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in
-        create_input (
-          mkNamedProd n (mkFullInd ind (2*nparrec)) (
-            mkNamedProd m (mkFullInd ind (2*nparrec+1)) (
-              mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|])
-          )
-        )
-      )
-
-let compute_dec_tact ind lnamesparrec nparrec =
-  let eq = Lazy.force eq and tt = Lazy.force tt 
-  and ff = Lazy.force ff and bb = Lazy.force bb in
-  let list_id = list_id lnamesparrec in
-  let eqI, eff = eqI ind lnamesparrec in
-  let avoid = ref [] in
-  let eqtrue x = mkApp(eq,[|bb;x;tt|]) in
-  let eqfalse x = mkApp(eq,[|bb;x;ff|]) in
-  let first_intros =
-      ( List.map (fun (s,_,_,_) -> s ) list_id ) @
-      ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
-      ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @
-      ( List.map (fun (_,_,_,slb) -> slb) list_id )
-  in
-  let fresh_id s gl =
-    Tacmach.New.of_old begin fun gsig ->
-      let fresh = fresh_id (!avoid) s gsig in
-      avoid := fresh::(!avoid); fresh
-    end gl
-  in
-  Proofview.Goal.nf_enter { enter = begin fun gl ->
-  let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
-  let freshn = fresh_id (Id.of_string "x") gl in
-  let freshm = fresh_id (Id.of_string "y") gl in
-  let freshH = fresh_id (Id.of_string "H") gl in
-  let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in
-  let arfresh = Array.of_list fresh_first_intros in
-  let xargs = Array.sub arfresh 0 (2*nparrec) in
-  begin try
-          let c, eff = find_scheme bl_scheme_kind ind in
-          Proofview.tclUNIT (mkConst c,eff) with
-    Not_found ->
-      Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.")
-  end >>= fun (blI,eff') ->
-  begin try
-          let c, eff = find_scheme lb_scheme_kind ind in
-          Proofview.tclUNIT (mkConst c,eff) with
-    Not_found ->
-      Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.")
-  end >>= fun (lbI,eff'') ->
-  let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in
-  Tacticals.New.tclTHENLIST [
-        Proofview.tclEFFECTS eff;
-        intros_using fresh_first_intros;
-        intros_using [freshn;freshm];
-	(*we do this so we don't have to prove the same goal twice *)
-        assert_by (Name freshH) (
-          mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|])
-	)
-	  (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto);
-
-        Proofview.Goal.nf_enter { enter = begin fun gl ->
-          let freshH2 = fresh_id (Id.of_string "H") gl in
-	  Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
-	    (* left *)
-	    Tacticals.New.tclTHENLIST [
-	      simplest_left;
-              apply (mkApp(blI,Array.map(fun x->mkVar x) xargs));
-              Auto.default_auto
-            ]
-            ;
-
-	    (*right *)
-            Proofview.Goal.nf_enter { enter = begin fun gl ->
-            let freshH3 = fresh_id (Id.of_string "H") gl in
-            Tacticals.New.tclTHENLIST [
-	      simplest_right ;
-              unfold_constr (Lazy.force Coqlib.coq_not_ref);
-              intro;
-              Equality.subst_all ();
-              assert_by (Name freshH3)
-		(mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))
-		(Tacticals.New.tclTHENLIST [
-		  apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs));
-                  Auto.default_auto
-		]);
-	      Equality.general_rewrite_bindings_in true
-	                      Locus.AllOccurrences true false
-                              (List.hd !avoid)
-                              ((mkVar (List.hd (List.tl !avoid))),
-                                NoBindings
-                              )
-                              true;
-              Equality.discr_tac false None
-	    ]
-            end }
-	  ]
-        end }
-  ]
-  end }
-
-let make_eq_decidability mode mind =
-  let mib = Global.lookup_mind mind in
-  if not (Int.equal (Array.length mib.mind_packets) 1) then
-    raise DecidabilityMutualNotSupported;
-  let ind = (mind,0) in
-  let nparams = mib.mind_nparams in
-  let nparrec = mib.mind_nparams_rec in
-  let u = Univ.Instance.empty in
-  let ctx = Evd.make_evar_universe_context (Global.env ()) None in
-  let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  let side_eff = side_effect_of_mode mode in
-  let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx
-    (compute_dec_goal (ind,u) lnamesparrec nparrec)
-    (compute_dec_tact ind lnamesparrec nparrec)
-  in
-  ([|ans|], ctx), Safe_typing.empty_private_constants
-
-let eq_dec_scheme_kind =
-  declare_mutual_scheme_object "_eq_dec" make_eq_decidability
-
-(* The eq_dec_scheme proofs depend on the equality and discr tactics
-   but the inj tactics, that comes with discr, depends on the
-   eq_dec_scheme... *)
-
-let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
deleted file mode 100644
index fa5c6148..00000000
--- a/toplevel/auto_ind_decl.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Ind_tables
-
-(** This file is about the automatic generation of schemes about
-    decidable equality,
-    @author Vincent Siles
-    Oct 2007 *)
-
-(** {6 Build boolean equality of a block of mutual inductive types } *)
-
-exception EqNotFound of inductive * inductive
-exception EqUnknown of string
-exception UndefinedCst of string
-exception InductiveWithProduct
-exception InductiveWithSort
-exception ParameterWithoutEquality of Globnames.global_reference
-exception NonSingletonProp of inductive
-exception DecidabilityMutualNotSupported
-
-val beq_scheme_kind : mutual scheme_kind
-val build_beq_scheme : mutual_scheme_object_function
-
-(** {6 Build equivalence between boolean equality and Leibniz equality } *)
-
-val lb_scheme_kind : mutual scheme_kind
-val make_lb_scheme : mutual_scheme_object_function
-val bl_scheme_kind : mutual scheme_kind
-val make_bl_scheme : mutual_scheme_object_function
-
-(** {6 Build decidability of equality } *)
-
-val eq_dec_scheme_kind : mutual scheme_kind
-val make_eq_decidability : mutual_scheme_object_function
diff --git a/toplevel/class.ml b/toplevel/class.ml
deleted file mode 100644
index 6d53ec9d..00000000
--- a/toplevel/class.ml
+++ /dev/null
@@ -1,328 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open CErrors
-open Util
-open Pp
-open Names
-open Term
-open Vars
-open Termops
-open Entries
-open Environ
-open Classops
-open Declare
-open Globnames
-open Nametab
-open Decl_kinds
-
-let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL
-
-let loc_of_bool b = if b then `LOCAL else `GLOBAL
-
-(* Errors *)
-
-type coercion_error_kind =
-  | AlreadyExists
-  | NotAFunction
-  | NoSource of cl_typ option
-  | ForbiddenSourceClass of cl_typ
-  | NoTarget
-  | WrongTarget of cl_typ * cl_typ
-  | NotAClass of global_reference
-
-exception CoercionError of coercion_error_kind
-
-let explain_coercion_error g = function
-  | AlreadyExists ->
-      (Printer.pr_global g ++ str" is already a coercion")
-  | NotAFunction ->
-      (Printer.pr_global g ++ str" is not a function")
-  | NoSource (Some cl) ->
-      (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of "
-       ++ Printer.pr_global g)
-  | NoSource None ->
-      (str ": cannot find the source class of " ++ Printer.pr_global g)
-  | ForbiddenSourceClass cl ->
-      pr_class cl ++ str " cannot be a source class"
-  | NoTarget ->
-      (str"Cannot find the target class")
-  | WrongTarget (clt,cl) ->
-      (str"Found target class " ++ pr_class cl ++
-       str " instead of " ++ pr_class clt)
-  | NotAClass ref ->
-      (str "Type of " ++ Printer.pr_global ref ++
-         str " does not end with a sort")
-
-(* Verifications pour l'ajout d'une classe *)
-
-let check_reference_arity ref =
-  if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then
-    raise (CoercionError (NotAClass ref))
-
-let check_arity = function
-  | CL_FUN | CL_SORT -> ()
-  | CL_CONST cst -> check_reference_arity (ConstRef cst)
-  | CL_PROJ cst -> check_reference_arity (ConstRef cst)
-  | CL_SECVAR id -> check_reference_arity (VarRef id)
-  | CL_IND kn -> check_reference_arity (IndRef kn)
-
-(* Coercions *)
-
-(* check that the computed target is the provided one *)
-let check_target clt = function
-  | Some cl when not (cl_typ_eq cl clt) -> raise (CoercionError (WrongTarget(clt,cl)))
-  | _ -> ()
-
-(* condition d'heritage uniforme *)
-
-let uniform_cond nargs lt =
-  let rec aux = function
-    | (0,[]) -> true
-    | (n,t::l) ->
-      let t = strip_outer_cast t in
-      isRel t && Int.equal (destRel t) n && aux ((n-1),l)
-    | _ -> false
-  in
-  aux (nargs,lt)
-
-let class_of_global = function
-  | ConstRef sp -> 
-    if Environ.is_projection sp (Global.env ()) 
-    then CL_PROJ sp else CL_CONST sp
-  | IndRef sp -> CL_IND sp
-  | VarRef id -> CL_SECVAR id
-  | ConstructRef _ as c ->
-      errorlabstrm "class_of_global"
-	(str "Constructors, such as " ++ Printer.pr_global c ++
-	   str ", cannot be used as a class.")
-
-(*
-lp est la liste (inverse'e) des arguments de la coercion
-ids est le nom de la classe source
-sps_opt est le sp de la classe source dans le cas des structures
-retourne:
-la classe source
-nbre d'arguments de la classe
-le constr de la class
-la liste des variables dont depend la classe source
-l'indice de la classe source dans la liste lp
-*)
-
-let get_source lp source =
-  match source with
-    | None ->
-	let (cl1,u1,lv1) =
-          match lp with
-	    | [] -> raise Not_found
-            | t1::_ -> find_class_type Evd.empty t1
-        in
-	(cl1,u1,lv1,1)
-    | Some cl ->
-	let rec aux = function
-	  | [] -> raise Not_found
-	  | t1::lt ->
-	      try
-		let cl1,u1,lv1 = find_class_type Evd.empty t1 in
-		if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1)
-		else raise Not_found
-              with Not_found -> aux lt
-	in aux (List.rev lp)
-
-let get_target t ind =
-  if (ind > 1) then
-    CL_FUN
-  else
-    match pi1 (find_class_type Evd.empty t) with
-    | CL_CONST p when Environ.is_projection p (Global.env ()) -> 
-      CL_PROJ p
-    | x -> x
-      
-
-let prods_of t =
-  let rec aux acc d = match kind_of_term d with
-    | Prod (_,c1,c2) -> aux (c1::acc) c2
-    | Cast (c,_,_) -> aux acc c
-    | _ -> (d,acc)
-  in
-  aux [] t
-
-let strength_of_cl = function
-  | CL_CONST kn -> `GLOBAL
-  | CL_SECVAR id -> `LOCAL
-  | _ -> `GLOBAL
-
-let strength_of_global = function
-  | VarRef _ -> `LOCAL
-  | _ -> `GLOBAL
-
-let get_strength stre ref cls clt =
-  let stres = strength_of_cl cls in
-  let stret = strength_of_cl clt in
-  let stref = strength_of_global ref in
-  strength_min [stre;stres;stret;stref]
-
-let ident_key_of_class = function
-  | CL_FUN -> "Funclass"
-  | CL_SORT -> "Sortclass"
-  | CL_CONST sp | CL_PROJ sp -> Label.to_string (con_label sp)
-  | CL_IND (sp,_) -> Label.to_string (mind_label sp)
-  | CL_SECVAR id -> Id.to_string id
-
-(* Identity coercion *)
-
-let error_not_transparent source =
-  errorlabstrm "build_id_coercion"
-    (pr_class source ++ str " must be a transparent constant.")
-
-let build_id_coercion idf_opt source poly =
-  let env = Global.env () in
-  let sigma = Evd.from_env env in
-  let sigma, vs = match source with
-    | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp)
-    | _ -> error_not_transparent source in
-  let c = match constant_opt_value_in env (destConst vs) with
-    | Some c -> c
-    | None -> error_not_transparent source in
-  let lams,t = decompose_lam_assum c in
-  let val_f =
-    it_mkLambda_or_LetIn
-      (mkLambda (Name Namegen.default_dependent_ident,
-		 applistc vs (Context.Rel.to_extended_list 0 lams),
-		 mkRel 1))
-       lams
-  in
-  let typ_f =
-    it_mkProd_wo_LetIn
-      (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t))
-      lams
-  in
-  (* juste pour verification *)
-  let _ =
-    if not
-      (Reductionops.is_conv_leq env sigma
-	(Typing.unsafe_type_of env sigma val_f) typ_f)
-    then
-      errorlabstrm "" (strbrk
-	"Cannot be defined as coercion (maybe a bad number of arguments).")
-  in
-  let idf =
-    match idf_opt with
-      | Some idf -> idf
-      | None ->
-	  let cl,u,_ = find_class_type sigma t in
-	  Id.of_string ("Id_"^(ident_key_of_class source)^"_"^
-                        (ident_key_of_class cl))
-  in
-  let constr_entry = (* Cast is necessary to express [val_f] is identity *)
-    DefinitionEntry
-      (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma))
-	 ~inline:true (mkCast (val_f, DEFAULTcast, typ_f)))
-  in
-  let decl = (constr_entry, IsDefinition IdentityCoercion) in
-  let kn = declare_constant idf decl in
-  ConstRef kn
-
-let check_source = function
-| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s))
-| _ -> ()
-
-(*
-nom de la fonction coercion
-strength de f
-nom de la classe source (optionnel)
-sp de la classe source (dans le cas des structures)
-nom de la classe target (optionnel)
-booleen "coercion identite'?"
-
-lorque source est None alors target est None aussi.
-*)
-
-let warn_uniform_inheritance =
-  CWarnings.create ~name:"uniform-inheritance" ~category:"typechecker"
-         (fun g ->
-          Printer.pr_global g ++
-            strbrk" does not respect the uniform inheritance condition")
-
-let add_new_coercion_core coef stre poly source target isid =
-  check_source source;
-  let t = Global.type_of_global_unsafe coef in
-  if coercion_exists coef then raise (CoercionError AlreadyExists);
-  let tg,lp = prods_of t in
-  let llp = List.length lp in
-  if Int.equal llp 0 then raise (CoercionError NotAFunction);
-  let (cls,us,lvs,ind) =
-    try
-      get_source lp source
-    with Not_found ->
-      raise (CoercionError (NoSource source))
-  in
-  check_source (Some cls);
-  if not (uniform_cond (llp-ind) lvs) then
-    warn_uniform_inheritance coef;
-  let clt =
-    try
-      get_target tg ind
-    with Not_found ->
-      raise (CoercionError NoTarget)
-  in
-  check_target clt target;
-  check_arity cls;
-  check_arity clt;
-  let local = match get_strength stre coef cls clt with
-  | `LOCAL -> true
-  | `GLOBAL -> false
-  in
-  declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs)
-
-
-let try_add_new_coercion_core ref ~local c d e f =
-  try add_new_coercion_core ref (loc_of_bool local) c d e f
-  with CoercionError e ->
-      errorlabstrm "try_add_new_coercion_core"
-        (explain_coercion_error ref e ++ str ".")
-
-let try_add_new_coercion ref ~local poly =
-  try_add_new_coercion_core ref ~local poly None None false
-
-let try_add_new_coercion_subclass cl ~local poly =
-  let coe_ref = build_id_coercion None cl poly in
-  try_add_new_coercion_core coe_ref ~local poly (Some cl) None true
-
-let try_add_new_coercion_with_target ref ~local poly ~source ~target =
-  try_add_new_coercion_core ref ~local poly (Some source) (Some target) false
-
-let try_add_new_identity_coercion id ~local poly ~source ~target =
-  let ref = build_id_coercion (Some id) source poly in
-  try_add_new_coercion_core ref ~local poly (Some source) (Some target) true
-
-let try_add_new_coercion_with_source ref ~local poly ~source =
-  try_add_new_coercion_core ref ~local poly (Some source) None false
-
-let add_coercion_hook poly local ref =
-  let stre = match local with
-  | Local -> true
-  | Global -> false
-  | Discharge -> assert false
-  in
-  let () = try_add_new_coercion ref stre poly in
-  let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in
-  Flags.if_verbose Feedback.msg_info msg
-
-let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly)
-
-let add_subclass_hook poly local ref =
-  let stre = match local with
-  | Local -> true
-  | Global -> false
-  | Discharge -> assert false
-  in
-  let cl = class_of_global ref in
-  try_add_new_coercion_subclass cl stre poly
-
-let add_subclass_hook poly = Lemmas.mk_hook (add_subclass_hook poly)
diff --git a/toplevel/class.mli b/toplevel/class.mli
deleted file mode 100644
index 5f9ae28f..00000000
--- a/toplevel/class.mli
+++ /dev/null
@@ -1,48 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Classops
-open Globnames
-
-(** Classes and coercions. *)
-
-(** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
-   from [src] to [tg] *)
-val try_add_new_coercion_with_target : global_reference -> local:bool -> 
-  Decl_kinds.polymorphic ->
-  source:cl_typ -> target:cl_typ ->  unit
-
-(** [try_add_new_coercion ref s] declares [ref], assumed to be of type
-   [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
-val try_add_new_coercion : global_reference -> local:bool -> 
-  Decl_kinds.polymorphic -> unit
-
-(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
-   transparent constant which unfolds to some class [tg]; it declares
-   an identity coercion from [cst] to [tg], named something like
-   ["Id_cst_tg"] *)
-val try_add_new_coercion_subclass : cl_typ -> local:bool -> 
-  Decl_kinds.polymorphic -> unit
-
-(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
-   from [src] to [tg] where the target is inferred from the type of [ref] *)
-val try_add_new_coercion_with_source : global_reference -> local:bool -> 
-  Decl_kinds.polymorphic -> source:cl_typ -> unit
-
-(** [try_add_new_identity_coercion id s src tg] enriches the
-   environment with a new definition of name [id] declared as an
-   identity coercion from [src] to [tg] *)
-val try_add_new_identity_coercion : Id.t -> local:bool -> 
-  Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit
-
-val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
-
-val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
-
-val class_of_global : global_reference -> cl_typ
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
deleted file mode 100644
index 1528cbb2..00000000
--- a/toplevel/classes.ml
+++ /dev/null
@@ -1,408 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Term
-open Vars
-open Environ
-open Nametab
-open CErrors
-open Util
-open Typeclasses_errors
-open Typeclasses
-open Libnames
-open Globnames
-open Constrintern
-open Constrexpr
-open Sigma.Notations
-open Context.Rel.Declaration
-(*i*)
-
-open Decl_kinds
-open Entries
-
-let refine_instance = ref true
-
-let _ = Goptions.declare_bool_option {
-  Goptions.optsync  = true;
-  Goptions.optdepr  = false;
-  Goptions.optname  = "definition of instances by refining";
-  Goptions.optkey   = ["Refine";"Instance";"Mode"];
-  Goptions.optread  = (fun () -> !refine_instance);
-  Goptions.optwrite = (fun b -> refine_instance := b)
-}
-
-let typeclasses_db = "typeclass_instances"
-
-let set_typeclass_transparency c local b = 
-  Hints.add_hints local [typeclasses_db] 
-    (Hints.HintsTransparencyEntry ([c], b))
-    
-let _ =
-  Hook.set Typeclasses.add_instance_hint_hook
-    (fun inst path local info poly ->
-     let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty)
-       | IsGlobal gr -> Hints.IsGlobRef gr
-     in
-     let info =
-       let open Vernacexpr in
-       { info with hint_pattern =
-		   Option.map
-		     (Constrintern.intern_constr_pattern (Global.env()))
-		     info.hint_pattern } in
-     Flags.silently (fun () ->
-	Hints.add_hints local [typeclasses_db]
-	  (Hints.HintsResolveEntry
-	     [info, poly, false, Hints.PathHints path, inst'])) ());
-  Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency;
-  Hook.set Typeclasses.classes_transparent_state_hook
-    (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db))
-
-open Vernacexpr
-
-(** TODO: add subinstances *)
-let existing_instance glob g info =
-  let c = global g in
-  let info = Option.default Hints.empty_hint_info info in
-  let instance = Global.type_of_global_unsafe c in
-  let _, r = decompose_prod_assum instance in
-    match class_of_constr r with
-      | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob
-  (*FIXME*) (Flags.use_polymorphic_flag ()) c)
-      | None -> user_err_loc (loc_of_reference g, "declare_instance",
-			     Pp.str "Constant does not build instances of a declared type class.")
-
-let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
-let mismatched_props env n m = mismatched_ctx_inst env Properties n m
-
-(* Declare everything in the parameters as implicit, and the class instance as well *)
-
-let type_ctx_instance evars env ctx inst subst =
-  let rec aux (subst, instctx) l = function
-    decl :: ctx ->
-      let t' = substl subst (get_type decl) in
-      let c', l =
-	match decl with
-	| LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l
-	| LocalDef (_,b,_) -> substl subst b, l
-      in
-      let d = get_name decl, Some c', t' in
-	aux (c' :: subst, d :: instctx) l ctx
-    | [] -> subst
-  in aux (subst, []) inst (List.rev ctx)
-
-let id_of_class cl =
-  match cl.cl_impl with
-    | ConstRef kn -> let _,_,l = repr_con kn in Label.to_id l
-    | IndRef (kn,i) ->
-	let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in
-	  mip.(0).Declarations.mind_typename
-    | _ -> assert false
-
-open Pp
-
-let instance_hook k info global imps ?hook cst =
-  Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
-  Typeclasses.declare_instance (Some info) (not global) cst;
-  (match hook with Some h -> h cst | None -> ())
-
-let declare_instance_constant k info global imps ?hook id pl poly evm term termtype =
-  let kind = IsDefinition Instance in
-  let evm = 
-    let levels = Univ.LSet.union (Universes.universes_of_constr termtype) 
-				 (Universes.universes_of_constr term) in
-    Evd.restrict_universe_context evm levels 
-  in
-  let pl, uctx = Evd.universe_context ?names:pl evm in
-  let entry = 
-    Declare.definition_entry ~types:termtype ~poly ~univs:uctx term
-  in
-  let cdecl = (DefinitionEntry entry, kind) in
-  let kn = Declare.declare_constant id cdecl in
-    Declare.definition_message id;
-    Universes.register_universe_binders (ConstRef kn) pl;
-    instance_hook k info global imps ?hook (ConstRef kn);
-    id
-
-let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props
-    ?(generalize=true)
-    ?(tac:unit Proofview.tactic option) ?hook pri =
-  let env = Global.env() in
-  let ((loc, instid), pl) = instid in
-  let uctx = Evd.make_evar_universe_context env pl in
-  let evars = ref (Evd.from_ctx uctx) in
-  let tclass, ids =
-    match bk with
-    | Decl_kinds.Implicit ->
-	Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false
-	  (fun avoid (clname, _) ->
-	    match clname with
-	    | Some (cl, b) ->
-		let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
-		  t, avoid
-	    | None -> failwith ("new instance: under-applied typeclass"))
-	  cl
-    | Explicit -> cl, Id.Set.empty
-  in
-  let tclass = 
-    if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) 
-    else tclass 
-  in
-  let k, u, cty, ctx', ctx, len, imps, subst =
-    let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in
-    let c', imps' = interp_type_evars_impls ~impls env' evars tclass in
-    let len = List.length ctx in
-    let imps = imps @ Impargs.lift_implicits len imps' in
-    let ctx', c = decompose_prod_assum c' in
-    let ctx'' = ctx' @ ctx in
-    let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
-    let cl, u = Typeclasses.typeclass_univ_instance k in
-    let _, args = 
-      List.fold_right (fun decl (args, args') ->
-        let open Context.Rel.Declaration in
-	match decl with
-	| LocalAssum _ -> (List.tl args, List.hd args :: args')
-	| LocalDef (_,b,_) -> (args, substl args' b :: args'))
-	(snd cl.cl_context) (args, [])
-    in
-      cl, u, c', ctx', ctx, len, imps, args
-  in
-  let id =
-    match instid with
-	Name id ->
-	  let sp = Lib.make_path id in
-	    if Nametab.exists_cci sp then
-	      errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists.");
-	    id
-      | Anonymous ->
-	  let i = Nameops.add_suffix (id_of_class k) "_instance_0" in
-	    Namegen.next_global_ident_away i (Termops.ids_of_context env)
-  in
-  let env' = push_rel_context ctx env in
-  evars := Evarutil.nf_evar_map !evars;
-  evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars;
-  let subst = List.map (Evarutil.nf_evar !evars) subst in
-    if abstract then
-      begin
-	let subst = List.fold_left2
-	  (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
-	  [] subst (snd k.cl_context)
-	in
-	let (_, ty_constr) = instance_constructor (k,u) subst in
-	let nf, subst = Evarutil.e_nf_evars_and_universes evars in
-	let termtype =
-	  let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	    nf t
-	in
-	Pretyping.check_evars env Evd.empty !evars termtype;
-	let pl, ctx = Evd.universe_context ?names:pl !evars in
-	let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id
-	  (ParameterEntry 
-            (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical)
-	in
-	  Universes.register_universe_binders (ConstRef cst) pl;
-	  instance_hook k pri global imps ?hook (ConstRef cst); id
-      end
-    else (
-      let props =
-	match props with
-	| Some (true, CRecord (loc, fs)) ->
-	    if List.length fs > List.length k.cl_props then
-	      mismatched_props env' (List.map snd fs) k.cl_props;
-	    Some (Inl fs)
-	| Some (_, t) -> Some (Inr t)
-	| None -> 
-	    if Flags.is_program_mode () then Some (Inl [])
-	    else None
-      in
-      let subst =
-	match props with
-	| None -> if List.is_empty k.cl_props then Some (Inl subst) else None
-	| Some (Inr term) ->
-	    let c = interp_casted_constr_evars env' evars term cty in
-	      Some (Inr (c, subst))
-	| Some (Inl props) ->
-	    let get_id =
-	      function
-		| Ident id' -> id'
-		| Qualid (loc,id') -> (loc, snd (repr_qualid id'))
-	    in
-	    let props, rest =
-	      List.fold_left
-		(fun (props, rest) decl ->
-		  if is_local_assum decl then
-		    try
-		      let is_id (id', _) = match get_name decl, get_id id' with
-			| Name id, (_, id') -> Id.equal id id'
-			| Anonymous, _ -> false
-                      in
-		       let (loc_mid, c) =
-			 List.find is_id rest 
-		       in
-		       let rest' = 
-			 List.filter (fun v -> not (is_id v)) rest 
-		       in
-		       let (loc, mid) = get_id loc_mid in
-			 List.iter (fun (n, _, x) -> 
-				      if Name.equal n (Name mid) then
-					Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
-			   k.cl_projs;
-			 c :: props, rest'
-		     with Not_found ->
-		       (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest
-		   else props, rest)
-		([], props) k.cl_props
-	    in
-              match rest with
-              | (n, _) :: _ ->
-		unbound_method env' k.cl_impl (get_id n)
-              | _ ->
-		Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') 
-			     k.cl_props props subst))
-      in	  
-      let term, termtype =
-	match subst with
-	| None -> let termtype = it_mkProd_or_LetIn cty ctx in
-	    None, termtype
-	| Some (Inl subst) ->
-	  let subst = List.fold_left2
-	    (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
-	    [] subst (k.cl_props @ snd k.cl_context)
-	  in
-	  let (app, ty_constr) = instance_constructor (k,u) subst in
-	  let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	  let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
-	    Some term, termtype
-	| Some (Inr (def, subst)) ->
-	  let termtype = it_mkProd_or_LetIn cty ctx in
-	  let term = Termops.it_mkLambda_or_LetIn def ctx in
-	    Some term, termtype
-      in
-      let _ = 
-	evars := Evarutil.nf_evar_map !evars;
-	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true
-          env !evars;
-	(* Try resolving fields that are typeclasses automatically. *)
-	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
-	  env !evars
-      in
-      let _ = evars := Evarutil.nf_evar_map_undefined !evars in
-      let evm, nf = Evarutil.nf_evar_map_universes !evars in
-      let termtype = nf termtype in
-      let _ = (* Check that the type is free of evars now. *)
-	Pretyping.check_evars env Evd.empty evm termtype
-      in
-      let term = Option.map nf term in
-	if not (Evd.has_undefined evm) && not (Option.is_empty term) then
-	  declare_instance_constant k pri global imps ?hook id pl
-            poly evm (Option.get term) termtype
-	else if Flags.is_program_mode () || refine || Option.is_empty term then begin
-	  let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in
-	    if Flags.is_program_mode () then
-	      let hook vis gr _ =
-		let cst = match gr with ConstRef kn -> kn | _ -> assert false in
-		  Impargs.declare_manual_implicits false gr ~enriching:false [imps];
-		  Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst)
-	      in
-	      let obls, constr, typ =
-		match term with 
-		| Some t -> 
-		  let obls, _, constr, typ = 
-		    Obligations.eterm_obligations env id evm 0 t termtype
-		  in obls, Some constr, typ
-		| None -> [||], None, termtype
-	      in
-              let hook = Lemmas.mk_hook hook in
-	      let ctx = Evd.evar_universe_context evm in
-		ignore (Obligations.add_definition id ?term:constr
- 			?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls);
-		id
-	    else
-	      (Flags.silently 
-	       (fun () ->
-                  (* spiwack: it is hard to reorder the actions to do
-                     the pretyping after the proof has opened. As a
-                     consequence, we use the low-level primitives to code
-                     the refinement manually.*)
-		let gls = List.rev (Evd.future_goals evm) in
-                let evm = Evd.reset_future_goals evm in
-                Lemmas.start_proof id kind evm termtype
-		(Lemmas.mk_hook
-                  (fun _ -> instance_hook k pri global imps ?hook));
-                 (* spiwack: I don't know what to do with the status here. *)
-		if not (Option.is_empty term) then
-                  let init_refine =
-                    Tacticals.New.tclTHENLIST [
-                      Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) };
-                      Proofview.Unsafe.tclNEWGOALS gls;
-                      Tactics.New.reduce_after_refine;
-                    ]
-                  in
-		  ignore (Pfedit.by init_refine)
-		else if Flags.is_auto_intros () then
-		  ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro));
-		(match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) ();
-	       id)
-	end
-      else CErrors.error "Unsolved obligations remaining.")
-	
-let named_of_rel_context l =
-  let acc, ctx =
-    List.fold_right
-      (fun decl (subst, ctx) ->
-        let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in
-	let d = match decl with
-	  | LocalAssum (_,t) -> id, None, substl subst t
-	  | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in
-	  (mkVar id :: subst, d :: ctx))
-      l ([], [])
-  in ctx
-
-let context poly l =
-  let env = Global.env() in
-  let evars = ref (Evd.from_env env) in
-  let _, ((env', fullctx), impls) = interp_context_evars env evars l in
-  let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in
-  let fullctx = Context.Rel.map subst fullctx in
-  let ce t = Pretyping.check_evars env Evd.empty !evars t in
-  let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in
-  let ctx =
-    try named_of_rel_context fullctx
-    with e when CErrors.noncritical e ->
-      error "Anonymous variables not allowed in contexts."
-  in
-  let uctx = ref (Evd.universe_context_set !evars) in
-  let fn status (id, b, t) =
-    if Lib.is_modtype () && not (Lib.sections_are_opened ()) then
-      let ctx = Univ.ContextSet.to_context !uctx in
-      (* Declare the universe context once *)
-      let () = uctx := Univ.ContextSet.empty in
-      let decl = (ParameterEntry (None,poly,(t,ctx),None), IsAssumption Logical) in
-      let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in
-	match class_of_constr t with
-	| Some (rels, ((tc,_), args) as _cl) ->
-	    add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*)
-			    poly (ConstRef cst));
-            status
-	    (* declare_subclasses (ConstRef cst) cl *)
-	| None -> status
-    else
-      let test (x, _) = match x with
-      | ExplByPos (_, Some id') -> Id.equal id id'
-      | _ -> false
-      in
-      let impl = List.exists test impls in
-      let decl = (Discharge, poly, Definitional) in
-      let nstatus =
-        pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl
-          Vernacexpr.NoInline (Loc.ghost, id))
-      in
-      let () = uctx := Univ.ContextSet.empty in
-	status && nstatus
-  in List.fold_left fn true (List.rev ctx)
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
deleted file mode 100644
index d2cb788e..00000000
--- a/toplevel/classes.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Environ
-open Constrexpr
-open Typeclasses
-open Libnames
-
-(** Errors *)
-
-val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a
-
-val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a
-
-(** Instance declaration *)
-
-val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit
-(** globality, reference, optional priority and pattern information *)
-
-val declare_instance_constant :
-  typeclass ->
-  Vernacexpr.hint_info_expr -> (** priority *)
-  bool -> (** globality *)
-  Impargs.manual_explicitation list -> (** implicits *)
-  ?hook:(Globnames.global_reference -> unit) ->
-  Id.t -> (** name *)
-  Id.t Loc.located list option ->
-  bool -> (* polymorphic *)
-  Evd.evar_map -> (* Universes *)
-  Constr.t -> (** body *)
-  Term.types -> (** type *)
-  Names.Id.t
-
-val new_instance :
-  ?abstract:bool -> (** Not abstract by default. *)
-  ?global:bool -> (** Not global by default. *)
-  ?refine:bool -> (** Allow refinement *)
-  Decl_kinds.polymorphic ->
-  local_binder list ->
-  typeclass_constraint ->
-  (bool * constr_expr) option ->
-  ?generalize:bool ->
-  ?tac:unit Proofview.tactic  ->
-  ?hook:(Globnames.global_reference -> unit) ->
-  Vernacexpr.hint_info_expr ->
-  Id.t
-
-(** Setting opacity *)
-
-val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit
-
-(** For generation on names based on classes only *)
-
-val id_of_class : typeclass -> Id.t
-
-(** Context command *)
-
-(** returns [false] if, for lack of section, it declares an assumption
-    (unless in a module type). *)
-val context : Decl_kinds.polymorphic -> local_binder list -> bool
diff --git a/toplevel/command.ml b/toplevel/command.ml
deleted file mode 100644
index a9f2598e..00000000
--- a/toplevel/command.ml
+++ /dev/null
@@ -1,1355 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Util
-open Flags
-open Term
-open Vars
-open Termops
-open Environ
-open Redexpr
-open Declare
-open Names
-open Libnames
-open Globnames
-open Nameops
-open Constrexpr
-open Constrexpr_ops
-open Topconstr
-open Constrintern
-open Nametab
-open Impargs
-open Reductionops
-open Indtypes
-open Decl_kinds
-open Pretyping
-open Evarutil
-open Evarconv
-open Indschemes
-open Misctypes
-open Vernacexpr
-open Sigma.Notations
-open Context.Rel.Declaration
-open Entries
-
-let do_universe poly l = Declare.do_universe poly l
-let do_constraint poly l = Declare.do_constraint poly l
-
-let rec under_binders env sigma f n c =
-  if Int.equal n 0 then f env sigma c else
-    match kind_of_term c with
-      | Lambda (x,t,c) ->
-	  mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c)
-      | LetIn (x,b,t,c) ->
-	  mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c)
-      | _ -> assert false
-
-let rec complete_conclusion a cs = function
-  | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c)
-  | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c)
-  | CHole (loc, k, _, _) ->
-      let (has_no_args,name,params) = a in
-      if not has_no_args then
-	user_err_loc (loc,"",
-	  strbrk"Cannot infer the non constant arguments of the conclusion of "
-	  ++ pr_id cs ++ str ".");
-      let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in
-      CAppExpl (loc,(None,Ident(loc,name),None),List.rev args)
-  | c -> c
-
-(* Commands of the interface *)
-
-(* 1| Constant definitions *)
-
-let red_constant_entry n ce sigma = function
-  | None -> ce
-  | Some red ->
-      let proof_out = ce.const_entry_body in
-      let env = Global.env () in
-      let (redfun, _) = reduction_of_red_expr env red in
-      let redfun env sigma c =
-        let sigma = Sigma.Unsafe.of_evar_map sigma in
-        let Sigma (c, _, _) = redfun.e_redfun env sigma c in
-        c
-      in
-      { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out
-        (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
-
-let warn_implicits_in_term =
-  CWarnings.create ~name:"implicits-in-term" ~category:"implicits"
-         (fun () ->
-          strbrk "Implicit arguments declaration relies on type." ++ spc () ++
-            strbrk "The term declares more implicits than the type here.")
-        
-let interp_definition pl bl p red_option c ctypopt =
-  let env = Global.env() in
-  let ctx = Evd.make_evar_universe_context env pl in
-  let evdref = ref (Evd.from_ctx ctx) in
-  let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in
-  let nb_args = List.length ctx in
-  let imps,pl,ce =
-    match ctypopt with
-      None ->
-        let subst = evd_comb0 Evd.nf_univ_variables evdref in
-	let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in
-	let env_bl = push_rel_context ctx env in
-	let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in
-        let nf,subst = Evarutil.e_nf_evars_and_universes evdref in
-        let body = nf (it_mkLambda_or_LetIn c ctx) in
-	let vars = Universes.universes_of_constr body in
-	let evd = Evd.restrict_universe_context !evdref vars in
-	let pl, uctx = Evd.universe_context ?names:pl evd in
- 	imps1@(Impargs.lift_implicits nb_args imps2), pl,
-	  definition_entry ~univs:uctx ~poly:p body
-    | Some ctyp ->
-	let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in
-	let subst = evd_comb0 Evd.nf_univ_variables evdref in
-	let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in
-	let env_bl = push_rel_context ctx env in
-	let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in
-	let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
-	let body = nf (it_mkLambda_or_LetIn c ctx) in
-	let typ = nf (it_mkProd_or_LetIn ty ctx) in
-        let beq b1 b2 = if b1 then b2 else not b2 in
-        let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in
-	(* Check that all implicit arguments inferable from the term
-           are inferable from the type *)
-        let chk (key,va) =
-          impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *)
-        in
-	if not (try List.for_all chk imps2 with Not_found -> false)
-	then warn_implicits_in_term ();
-        let vars = Univ.LSet.union (Universes.universes_of_constr body) 
-          (Universes.universes_of_constr typ) in
-        let ctx = Evd.restrict_universe_context !evdref vars in
-	let pl, uctx = Evd.universe_context ?names:pl ctx in
-	imps1@(Impargs.lift_implicits nb_args impsty), pl,
-	  definition_entry ~types:typ ~poly:p 
-	    ~univs:uctx body
-  in
-  red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps
-
-let check_definition (ce, evd, _, imps) =
-  check_evars_are_solved (Global.env ()) evd (Evd.empty,evd);
-  ce
-
-let warn_local_declaration =
-  CWarnings.create ~name:"local-declaration" ~category:"scope"
-         (fun (id,kind) ->
-          pr_id id ++ strbrk " is declared as a local " ++ str kind)
-
-let get_locality id ~kind = function
-| Discharge ->
-  (** If a Let is defined outside a section, then we consider it as a local definition *)
-   warn_local_declaration (id,kind);
-  true
-| Local -> true
-| Global -> false
-
-let declare_global_definition ident ce local k pl imps =
-  let local = get_locality ident ~kind:"definition" local in
-  let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in
-  let gr = ConstRef kn in
-  let () = maybe_declare_manual_implicits false gr imps in
-  let () = Universes.register_universe_binders gr pl in
-  let () = definition_message ident in
-  gr
-
-let declare_definition_hook = ref ignore
-let set_declare_definition_hook = (:=) declare_definition_hook
-let get_declare_definition_hook () = !declare_definition_hook
-
-let warn_definition_not_visible =
-  CWarnings.create ~name:"definition-not-visible" ~category:"implicits"
-         (fun ident ->
-          strbrk "Section definition " ++
-            pr_id ident ++ strbrk " is not visible from current goals")
-
-let declare_definition ident (local, p, k) ce pl imps hook =
-  let fix_exn = Future.fix_exn_of ce.const_entry_body in
-  let () = !declare_definition_hook ce in
-  let r = match local with
-  | Discharge when Lib.sections_are_opened () ->
-    let c = SectionLocalDef ce in
-    let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in
-    let () = definition_message ident in
-    let gr = VarRef ident in
-    let () = maybe_declare_manual_implicits false gr imps in
-    let () = if Pfedit.refining () then
-	       warn_definition_not_visible ident
-    in
-    gr
-  | Discharge | Local | Global ->
-    declare_global_definition ident ce local k pl imps in
-  Lemmas.call_hook fix_exn hook local r
-
-let _ = Obligations.declare_definition_ref :=
-       (fun i k c imps hook -> declare_definition i k c [] imps hook)
-
-let do_definition ident k pl bl red_option c ctypopt hook =
-  let (ce, evd, pl', imps as def) =
-    interp_definition pl bl (pi2 k) red_option c ctypopt
-  in
-    if Flags.is_program_mode () then
-      let env = Global.env () in
-      let (c,ctx), sideff = Future.force ce.const_entry_body in
-      assert(Safe_typing.empty_private_constants = sideff);
-      assert(Univ.ContextSet.is_empty ctx);
-      let typ = match ce.const_entry_type with 
-	| Some t -> t
-	| None -> Retyping.get_type_of env evd c
-      in 
-      Obligations.check_evars env evd;
-      let obls, _, c, cty = 
-	Obligations.eterm_obligations env ident evd 0 c typ
-      in
-      let ctx = Evd.evar_universe_context evd in
-      let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in
-	ignore(Obligations.add_definition
-          ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls)
-    else let ce = check_definition def in
-      ignore(declare_definition ident k ce pl' imps
-        (Lemmas.mk_hook
-          (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r)))
-
-(* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
-
-let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) =
-match local with
-| Discharge when Lib.sections_are_opened () ->
-  let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in
-  let _ = declare_variable ident decl in
-  let () = assumption_message ident in
-  let () =
-    if is_verbose () && Pfedit.refining () then
-    Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++
-    strbrk " is not visible from current goals")
-  in
-  let r = VarRef ident in
-  let () = Typeclasses.declare_instance None true r in
-  let () = if is_coe then Class.try_add_new_coercion r ~local:true false in
-  (r,Univ.Instance.empty,true)
-
-| Global | Local | Discharge ->
-  let local = get_locality ident ~kind:"axiom" local in
-  let inl = match nl with
-    | NoInline -> None
-    | DefaultInline -> Some (Flags.get_inline_level())
-    | InlineAt i -> Some i
-  in
-  let ctx = Univ.ContextSet.to_context ctx in
-  let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in
-  let kn = declare_constant ident ~local decl in
-  let gr = ConstRef kn in
-  let () = maybe_declare_manual_implicits false gr imps in
-  let () = Universes.register_universe_binders gr pl in
-  let () = assumption_message ident in
-  let () = Typeclasses.declare_instance None false gr in
-  let () = if is_coe then Class.try_add_new_coercion gr local p in
-  let inst = 
-    if p (* polymorphic *) then Univ.UContext.instance ctx 
-    else Univ.Instance.empty
-  in
-    (gr,inst,Lib.is_modtype_strict ())
-
-let interp_assumption evdref env impls bl c =
-  let c = prod_constr_expr c bl in
-  interp_type_evars_impls env evdref ~impls c
-
-let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl =
-  let refs, status, _ =
-    List.fold_left (fun (refs,status,ctx) id ->
-      let ref',u',status' =
-	declare_assumption is_coe k (c,ctx) pl imps impl_is_on nl id in
-      (ref',u')::refs, status' && status, Univ.ContextSet.empty)
-      ([],true,ctx) idl
-  in
-  List.rev refs, status
-
-let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
-  let open Context.Named.Declaration in
-  let env = Global.env () in
-  let evdref = ref (Evd.from_env env) in
-  let l = 
-    if poly then
-      (* Separate declarations so that A B : Type puts A and B in different levels. *)
-      List.fold_right (fun (is_coe,(idl,c)) acc ->
-        List.fold_right (fun id acc -> 
-	  (is_coe, ([id], c)) :: acc) idl acc)
-        l []
-    else l
-  in
-  (* We intepret all declarations in the same evar_map, i.e. as a telescope. *)
-  let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) ->
-    let t,imps = interp_assumption evdref env ienv [] c in
-    let env =
-      push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in
-    let ienv = List.fold_right (fun (_,id) ienv ->
-      let impls = compute_internalization_data env Variable t imps in
-      Id.Map.add id impls ienv) idl ienv in
-      ((env,ienv),((is_coe,idl),t,imps))) 
-    (env,empty_internalization_env) l
-  in
-  let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in
-  (* The universe constraints come from the whole telescope. *)
-  let evd = Evd.nf_constraints evd in
-  let ctx = Evd.universe_context_set evd in
-  let l = List.map (on_pi2 (nf_evar evd)) l in
-  pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) ->
-    let t = replace_vars subst t in
-    let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in
-    let subst' = List.map2 
-      (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u)))
-      idl refs 
-    in
-    (subst'@subst, status' && status,
-     (* The universe constraints are declared with the first declaration only. *)
-     Univ.ContextSet.empty)) ([],true,ctx) l)
-
-let do_assumptions_bound_univs coe kind nl id pl c =
-  let env = Global.env () in
-  let ctx = Evd.make_evar_universe_context env pl in
-  let evdref = ref (Evd.from_ctx ctx) in
-  let ty, impls = interp_type_evars_impls env evdref c in
-  let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
-  let ty = nf ty in
-  let vars = Universes.universes_of_constr ty in
-  let evd = Evd.restrict_universe_context !evdref vars in
-  let pl, uctx = Evd.universe_context ?names:pl evd in
-  let uctx = Univ.ContextSet.of_context uctx in
-  let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in
-  st
-
-let do_assumptions kind nl l = match l with
-| [coe, ([id, Some pl], c)] ->
-  let () = match kind with
-  | (Discharge, _, _) when Lib.sections_are_opened () ->
-    let loc = fst id in
-    let msg = Pp.str "Section variables cannot be polymorphic." in
-    user_err_loc (loc, "", msg)
-  | _ -> ()
-  in
-  do_assumptions_bound_univs coe kind nl id (Some pl) c
-| _ ->
-  let map (coe, (idl, c)) =
-    let map (id, univs) = match univs with
-    | None -> id
-    | Some _ ->
-      let loc = fst id in
-      let msg =
-	Pp.str "Assumptions with bound universes can only be defined one at a time." in
-      user_err_loc (loc, "", msg)
-    in
-    (coe, (List.map map idl, c))
-  in
-  let l = List.map map l in
-  do_assumptions_unbound_univs kind nl l
-
-(* 3a| Elimination schemes for mutual inductive definitions *)
-
-(* 3b| Mutual inductive definitions *)
-
-let push_types env idl tl =
-  List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env)
-    env idl tl
-
-type structured_one_inductive_expr = {
-  ind_name : Id.t;
-  ind_univs : lident list option;
-  ind_arity : constr_expr;
-  ind_lc : (Id.t * constr_expr) list
-}
-
-type structured_inductive_expr =
-  local_binder list * structured_one_inductive_expr list
-
-let minductive_message warn = function
-  | []  -> error "No inductive definition."
-  | [x] -> (pr_id x ++ str " is defined" ++ 
-	    if warn then str " as a non-primitive record" else mt())
-  | l   -> hov 0  (prlist_with_sep pr_comma pr_id l ++
-		     spc () ++ str "are defined")
-
-let check_all_names_different indl =
-  let ind_names = List.map (fun ind -> ind.ind_name) indl in
-  let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in
-  let l = List.duplicates Id.equal ind_names in
-  let () = match l with
-  | [] -> ()
-  | t :: _ -> raise (InductiveError (SameNamesTypes t))
-  in
-  let l = List.duplicates Id.equal cstr_names in
-  let () = match l with
-  | [] -> ()
-  | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l)))
-  in
-  let l = List.intersect Id.equal ind_names cstr_names in
-  match l with
-  | [] -> ()
-  | _ -> raise (InductiveError (SameNamesOverlap l))
-
-let mk_mltype_data evdref env assums arity indname =
-  let is_ml_type = is_sort env !evdref arity in
-  (is_ml_type,indname,assums)
-
-let prepare_param = function
-  | LocalAssum (na,t) -> out_name na, LocalAssumEntry t
-  | LocalDef (na,b,_) -> out_name na, LocalDefEntry b
-
-(** Make the arity conclusion flexible to avoid generating an upper bound universe now,
-    only if the universe does not appear anywhere else.
-    This is really a hack to stay compatible with the semantics of template polymorphic 
-    inductives which are recognized when a "Type" appears at the end of the conlusion in
-    the source syntax. *)
-    
-let rec check_anonymous_type ind =
-  let open Glob_term in
-    match ind with
-    | GSort (_, GType []) -> true
-    | GProd (_, _, _, _, e) 
-    | GLetIn (_, _, _, e)
-    | GLambda (_, _, _, _, e)
-    | GApp (_, e, _)
-    | GCast (_, e, _) -> check_anonymous_type e
-    | _ -> false
-
-let make_conclusion_flexible evdref ty poly =
-  if poly && isArity ty then
-    let _, concl = destArity ty in
-      match concl with
-      | Type u -> 
-        (match Univ.universe_level u with
-        | Some u -> 
-	  evdref := Evd.make_flexible_variable !evdref true u
-	| None -> ())
-      | _ -> ()
-  else () 
-	
-let is_impredicative env u = 
-  u = Prop Null || (is_impredicative_set env && u = Prop Pos)
-
-let interp_ind_arity env evdref ind =
-  let c = intern_gen IsType env ind.ind_arity in
-  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
-  let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in
-  let pseudo_poly = check_anonymous_type c in
-  let () = if not (Reduction.is_arity env t) then
-    user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity")
-  in
-    t, pseudo_poly, impls
-
-let interp_cstrs evdref env impls mldata arity ind =
-  let cnames,ctyps = List.split ind.ind_lc in
-  (* Complete conclusions of constructor types if given in ML-style syntax *)
-  let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in
-  (* Interpret the constructor types *)
-  let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in
-    (cnames, ctyps'', cimpls)
-
-let sign_level env evd sign =
-  fst (List.fold_right
-    (fun d (lev,env) ->
-      match d with
-      | LocalDef _ -> lev, push_rel d env
-      | LocalAssum _ ->
-	let s = destSort (Reduction.whd_all env 
-			    (nf_evar evd (Retyping.get_type_of env evd (get_type d))))
-	in
-	let u = univ_of_sort s in
-	  (Univ.sup u lev, push_rel d env))
-    sign (Univ.type0m_univ,env))
-
-let sup_list min = List.fold_left Univ.sup min
-
-let extract_level env evd min tys = 
-  let sorts = List.map (fun ty -> 
-    let ctx, concl = Reduction.dest_prod_assum env ty in
-      sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys
-  in sup_list min sorts
-
-let is_flexible_sort evd u =
-  match Univ.Universe.level u with
-  | Some l -> Evd.is_flexible_level evd l
-  | None -> false
-
-let inductive_levels env evdref poly arities inds =
-  let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in
-  let levels = List.map (fun (x,(ctx,a)) -> 
-    if a = Prop Null then None
-    else Some (univ_of_sort a)) destarities
-  in
-  let cstrs_levels, min_levels, sizes = 
-    CList.split3
-      (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> 
-	let len = List.length tys in
-	let minlev = Sorts.univ_of_sort du in
-	let minlev =
-	  if len > 1 && not (is_impredicative env du) then
-	    Univ.sup minlev Univ.type0_univ
-	  else minlev
-	in
-	let minlev =
-	  (** Indices contribute. *)
-	  if Indtypes.is_indices_matter () && List.length ctx > 0 then (
-	    let ilev = sign_level env !evdref ctx in
-	      Univ.sup ilev minlev)
-	  else minlev
-	in
-	let clev = extract_level env !evdref minlev tys in
-	  (clev, minlev, len)) inds destarities)
-  in
-  (* Take the transitive closure of the system of constructors *)
-  (* level constraints and remove the recursive dependencies *)
-  let levels' = Universes.solve_constraints_system (Array.of_list levels)
-    (Array.of_list cstrs_levels) (Array.of_list min_levels)
-  in
-  let evd, arities =
-    CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len ->
-      if is_impredicative env du then
-	(** Any product is allowed here. *)
-	evd, arity :: arities
-      else (** If in a predicative sort, or asked to infer the type,
-	       we take the max of:
-	       - indices (if in indices-matter mode)
-	       - constructors
-	       - Type(1) if there is more than 1 constructor
-	   *)
-        (** Constructors contribute. *)
-	let evd = 
-	  if Sorts.is_set du then
-	    if not (Evd.check_leq evd cu Univ.type0_univ) then 
-	      raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType)
-	    else evd
-	  else evd
-	    (* Evd.set_leq_sort env evd (Type cu) du *)
-	in
-	let evd = 
-	  if len >= 2 && Univ.is_type0m_univ cu then 
-	   (** "Polymorphic" type constraint and more than one constructor, 
-	       should not land in Prop. Add constraint only if it would
-	       land in Prop directly (no informative arguments as well). *)
-	    Evd.set_leq_sort env evd (Prop Pos) du
-	  else evd
-	in
-	let duu = Sorts.univ_of_sort du in
-	let evd =
-	  if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then
-	    if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then
-	      Evd.set_eq_sort env evd (Prop Null) du
-	    else evd
-	  else Evd.set_eq_sort env evd (Type cu) du
-	in
-	  (evd, arity :: arities))
-    (!evdref,[]) (Array.to_list levels') destarities sizes
-  in evdref := evd; List.rev arities
-
-let check_named (loc, na) = match na with
-| Name _ -> ()
-| Anonymous ->
-  let msg = str "Parameters must be named." in
-  user_err_loc (loc, "", msg)
-
-
-let check_param = function
-| LocalRawDef (na, _) -> check_named na
-| LocalRawAssum (nas, Default _, _) -> List.iter check_named nas
-| LocalRawAssum (nas, Generalized _, _) -> ()
-| LocalPattern _ -> assert false
-
-let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
-  check_all_names_different indl;
-  List.iter check_param paramsl;
-  let env0 = Global.env() in
-  let pl = (List.hd indl).ind_univs in
-  let ctx = Evd.make_evar_universe_context env0 pl in
-  let evdref = ref Evd.(from_ctx ctx) in
-  let _, ((env_params, ctx_params), userimpls) =
-    interp_context_evars env0 evdref paramsl
-  in
-  let indnames = List.map (fun ind -> ind.ind_name) indl in
-      
-  (* Names of parameters as arguments of the inductive type (defs removed) *)
-  let assums = List.filter is_local_assum ctx_params in
-  let params = List.map (fun decl -> out_name (get_name decl)) assums in
-
-  (* Interpret the arities *)
-  let arities = List.map (interp_ind_arity env_params evdref) indl in
-
-  let fullarities = List.map (fun (c, _, _) -> it_mkProd_or_LetIn c ctx_params) arities in
-  let env_ar = push_types env0 indnames fullarities in
-  let env_ar_params = push_rel_context ctx_params env_ar in
-
-  (* Compute interpretation metadatas *)
-  let indimpls = List.map (fun (_, _, impls) -> userimpls @ 
-    lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in
-  let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in
-  let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in
-  let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
-
-  let constructors =
-    Metasyntax.with_syntax_protection (fun () ->
-     (* Temporary declaration of notations and scopes *)
-     List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-     (* Interpret the constructor types *)
-     List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl)
-     () in
-
-  (* Try further to solve evars, and instantiate them *)
-  let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref (Evd.empty,!evdref) in
-  evdref := sigma;
-  (* Compute renewed arities *)
-  let nf,_ = e_nf_evars_and_universes evdref in
-  let arities = List.map nf arities in
-  let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in
-  let _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in
-  let arities = inductive_levels env_ar_params evdref poly arities constructors in
-  let nf',_ = e_nf_evars_and_universes evdref in
-  let nf x = nf' (nf x) in
-  let arities = List.map nf' arities in
-  let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in
-  let ctx_params = Context.Rel.map nf ctx_params in
-  let evd = !evdref in
-  let pl, uctx = Evd.universe_context ?names:pl evd in
-  List.iter (check_evars env_params Evd.empty evd) arities;
-  Context.Rel.iter (check_evars env0 Evd.empty evd) ctx_params;
-  List.iter (fun (_,ctyps,_) ->
-    List.iter (check_evars env_ar_params Evd.empty evd) ctyps)
-    constructors;
-
-  (* Build the inductive entries *)
-  let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> {
-    mind_entry_typename = ind.ind_name;
-    mind_entry_arity = arity;
-    mind_entry_template = template;
-    mind_entry_consnames = cnames;
-    mind_entry_lc = ctypes
-  }) indl arities aritypoly constructors in
-  let impls =
-    let len = Context.Rel.nhyps ctx_params in
-      List.map2 (fun indimpls (_,_,cimpls) ->
-	indimpls, List.map (fun impls ->
-	  userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors
-  in
-  (* Build the mutual inductive entry *)
-  { mind_entry_params = List.map prepare_param ctx_params;
-    mind_entry_record = None;
-    mind_entry_finite = finite;
-    mind_entry_inds = entries;
-    mind_entry_polymorphic = poly;
-    mind_entry_private = if prv then Some false else None;
-    mind_entry_universes = uctx;
-  },
-    pl, impls
-
-(* Very syntactical equality *)
-let eq_local_binders bl1 bl2 =
-  List.equal local_binder_eq bl1 bl2
-
-let extract_coercions indl =
-  let mkqid (_,((_,id),_)) = qualid_of_ident id in
-  let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in
-  List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl))
-
-let extract_params indl =
-  let paramsl = List.map (fun (_,params,_,_) -> params) indl in
-  match paramsl with
-  | [] -> anomaly (Pp.str "empty list of inductive types")
-  | params::paramsl ->
-      if not (List.for_all (eq_local_binders params) paramsl) then error
-	"Parameters should be syntactically the same for each inductive type.";
-      params
-
-let extract_inductive indl =
-  List.map (fun (((_,indname),pl),_,ar,lc) -> {
-    ind_name = indname; ind_univs = pl;
-    ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar;
-    ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
-  }) indl
-
-let extract_mutual_inductive_declaration_components indl =
-  let indl,ntnl = List.split indl in
-  let params = extract_params indl in
-  let coes = extract_coercions indl in
-  let indl = extract_inductive indl in
-  (params,indl), coes, List.flatten ntnl
-
-let is_recursive mie =
-  let rec is_recursive_constructor lift typ =
-    match Term.kind_of_term typ with
-    | Prod (_,arg,rest) ->
-        Termops.dependent (mkRel lift) arg ||
-        is_recursive_constructor (lift+1) rest
-    | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest
-    | _ -> false
-  in
-  match mie.mind_entry_inds with
-  | [ind] ->
-      let nparams = List.length mie.mind_entry_params in
-      List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc
-  | _ -> false
-
-let declare_mutual_inductive_with_eliminations mie pl impls =
-  (* spiwack: raises an error if the structure is supposed to be non-recursive,
-        but isn't *)
-  begin match mie.mind_entry_finite with
-  | BiFinite when is_recursive mie ->
-      if Option.has_some mie.mind_entry_record then
-        error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command."
-      else
-        error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")
-  | _ -> ()
-  end;
-  let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
-  let (_, kn), prim = declare_mind mie in
-  let mind = Global.mind_of_delta_kn kn in
-  List.iteri (fun i (indimpls, constrimpls) ->
-	      let ind = (mind,i) in
-	      let gr = IndRef ind in
-	      maybe_declare_manual_implicits false gr indimpls;
-	      Universes.register_universe_binders gr pl;
-	      List.iteri
-		(fun j impls ->
-		 maybe_declare_manual_implicits false
-		    (ConstructRef (ind, succ j)) impls)
-		constrimpls)
-      impls;
-  let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in
-  if_verbose Feedback.msg_info (minductive_message warn_prim names);
-  if mie.mind_entry_private == None
-  then declare_default_schemes mind;
-  mind
-
-type one_inductive_impls =
-  Impargs.manual_explicitation list (* for inds *)*
-  Impargs.manual_explicitation list list (* for constrs *)
-
-let do_mutual_inductive indl poly prv finite =
-  let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in
-  (* Interpret the types *)
-  let mie,pl,impls = interp_mutual_inductive indl ntns poly prv finite in
-  (* Declare the mutual inductive block with its associated schemes *)
-  ignore (declare_mutual_inductive_with_eliminations mie pl impls);
-  (* Declare the possible notations of inductive types *)
-  List.iter Metasyntax.add_notation_interpretation ntns;
-  (* Declare the coercions *)
-  List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes;
-  (* If positivity is assumed declares itself as unsafe. *)
-  if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else ()
-
-(* 3c| Fixpoints and co-fixpoints *)
-
-(* An (unoptimized) function that maps preorders to partial orders...
-
-   Input:  a list of associations (x,[y1;...;yn]), all yi distincts
-           and different of x, meaning x<=y1, ..., x<=yn
-
-   Output: a list of associations (x,Inr [y1;...;yn]), collecting all
-           distincts yi greater than x, _or_, (x, Inl y) meaning that
-           x is in the same class as y (in which case, x occurs
-           nowhere else in the association map)
-
-   partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list
-*)
-
-let rec partial_order cmp = function
-  | [] -> []
-  | (x,xge)::rest ->
-    let rec browse res xge' = function
-    | [] ->
-	let res = List.map (function
-	  | (z, Inr zge) when List.mem_f cmp x zge ->
-            (z, Inr (List.union cmp zge xge'))
-	  | r -> r) res in
-	(x,Inr xge')::res
-    | y::xge ->
-      let rec link y =
-	try match List.assoc_f cmp y res with
-	| Inl z -> link z
-	| Inr yge ->
-	  if List.mem_f cmp x yge then
-	    let res = List.remove_assoc_f cmp y res in
-	    let res = List.map (function
-	      | (z, Inl t) ->
-		  if cmp t y then (z, Inl x) else (z, Inl t)
-	      | (z, Inr zge) ->
-		  if List.mem_f cmp y zge then
-		    (z, Inr (List.add_set cmp x (List.remove cmp y zge)))
-		  else
-		    (z, Inr zge)) res in
-	    browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge))
-	  else
-	    browse res (List.add_set cmp y (List.union cmp xge' yge)) xge
-	with Not_found -> browse res (List.add_set cmp y xge') xge
-      in link y
-    in browse (partial_order cmp rest) [] xge
-
-let non_full_mutual_message x xge y yge isfix rest =
-  let reason =
-    if Id.List.mem x yge then
-      pr_id y ++ str " depends on " ++ pr_id x ++ strbrk " but not conversely"
-    else if Id.List.mem y xge then
-      pr_id x ++ str " depends on " ++ pr_id y ++ strbrk " but not conversely"
-    else
-      pr_id y ++ str " and " ++ pr_id x ++ strbrk " are not mutually dependent" in
-  let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in
-  let k = if isfix then "fixpoint" else "cofixpoint" in
-  let w =
-    if isfix
-    then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl()
-    else mt () in
-  strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++
-  str "(" ++ e ++ str ")." ++ fnl () ++ w
-
-let warn_non_full_mutual =
-  CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints"
-         (fun (x,xge,y,yge,isfix,rest) ->
-          non_full_mutual_message x xge y yge isfix rest)
-
-let check_mutuality env isfix fixl =
-  let names = List.map fst fixl in
-  let preorder =
-    List.map (fun (id,def) ->
-      (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names))
-      fixl in
-  let po = partial_order Id.equal preorder in
-  match List.filter (function (_,Inr _) -> true | _ -> false) po with
-    | (x,Inr xge)::(y,Inr yge)::rest ->
-       warn_non_full_mutual (x,xge,y,yge,isfix,rest)
-    | _ -> ()
-
-type structured_fixpoint_expr = {
-  fix_name : Id.t;
-  fix_univs : lident list option;
-  fix_annot : Id.t Loc.located option;
-  fix_binders : local_binder list;
-  fix_body : constr_expr option;
-  fix_type : constr_expr
-}
-
-let interp_fix_context env evdref isfix fix =
-  let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
-  let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in
-  let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(List.length before) env' evdref after in
-  let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
-    ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot)
-
-let interp_fix_ccl evdref impls (env,_) fix =
-  interp_type_evars_impls ~impls env evdref fix.fix_type
-
-let interp_fix_body env_rec evdref impls (_,ctx) fix ccl =
-  Option.map (fun body ->
-    let env = push_rel_context ctx env_rec in
-    let body = interp_casted_constr_evars env evdref ~impls body ccl in
-    it_mkLambda_or_LetIn body ctx) fix.fix_body
-
-let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-
-let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps =
-  let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in
-  declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r))
-
-let _ = Obligations.declare_fix_ref :=
-  (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps)
-
-let prepare_recursive_declaration fixnames fixtypes fixdefs =
-  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
-  let names = List.map (fun id -> Name id) fixnames in
-  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
-
-(* Jump over let-bindings. *)
-
-let compute_possible_guardness_evidences (ids,_,na) =
-  match na with
-  | Some i -> [i]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      List.interval 0 (List.length ids - 1)
-
-type recursive_preentry =
-  Id.t list * constr option list * types list
-
-(* Wellfounded definition *)
-
-open Coqlib
-
-let contrib_name = "Program"
-let subtac_dir = [contrib_name]
-let fixsub_module = subtac_dir @ ["Wf"]
-let tactics_module = subtac_dir @ ["Tactics"]
-
-let init_reference dir s () = Coqlib.gen_reference "Command" dir s
-let init_constant dir s () = Coqlib.gen_constant "Command" dir s
-let make_ref l s = init_reference l s
-let fix_proto = init_constant tactics_module "fix_proto"
-let fix_sub_ref = make_ref fixsub_module "Fix_sub"
-let measure_on_R_ref = make_ref fixsub_module "MR"
-let well_founded = init_constant ["Init"; "Wf"] "well_founded"
-let mkSubset name typ prop =
-  mkApp (Universes.constr_of_global (delayed_force build_sigma).typ,
-	 [| typ; mkLambda (name, typ, prop) |])
-let sigT = Lazy.from_fun build_sigma_type
-
-let make_qref s = Qualid (Loc.ghost, qualid_of_string s)
-let lt_ref = make_qref "Init.Peano.lt"
-
-let rec telescope = function
-  | [] -> assert false
-  | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1
-  | LocalAssum (n, t) :: tl ->
-      let ty, tys, (k, constr) =
-	List.fold_left
-	  (fun (ty, tys, (k, constr)) decl ->
-            let t = get_type decl in
-            let pred = mkLambda (get_name decl, t, ty) in
-	    let ty = Universes.constr_of_global (Lazy.force sigT).typ in
-	    let intro = Universes.constr_of_global (Lazy.force sigT).intro in
-	    let sigty = mkApp (ty, [|t; pred|]) in
-	    let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in
-	      (sigty, pred :: tys, (succ k, intro)))
-	  (t, [], (2, mkRel 1)) tl
-      in
-      let (last, subst) = List.fold_right2
-        (fun pred decl (prev, subst) ->
-          let t = get_type decl in
-	  let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in
-	  let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in
-	  let proj1 = applistc p1 [t; pred; prev] in
-	  let proj2 = applistc p2 [t; pred; prev] in
-	    (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst))
-	(List.rev tys) tl (mkRel 1, [])
-      in ty, (LocalDef (n, last, t) :: subst), constr
-
-  | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in
-      ty, (LocalDef (n, b, t) :: subst), lift 1 term
-
-let nf_evar_context sigma ctx =
-  List.map (map_constr (Evarutil.nf_evar sigma)) ctx
-
-let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
-  Coqlib.check_required_library ["Coq";"Program";"Wf"];
-  let env = Global.env() in
-  let ctx = Evd.make_evar_universe_context env pl in
-  let evdref = ref (Evd.from_ctx ctx) in
-  let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in
-  let len = List.length binders_rel in
-  let top_env = push_rel_context binders_rel env in
-  let top_arity = interp_type_evars top_env evdref arityc in
-  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
-  let argtyp, letbinders, make = telescope binders_rel in
-  let argname = Id.of_string "recarg" in
-  let arg = LocalAssum (Name argname, argtyp) in
-  let binders = letbinders @ [arg] in
-  let binders_env = push_rel_context binders_rel env in
-  let rel, _ = interp_constr_evars_impls env evdref r in
-  let relty = Typing.unsafe_type_of env !evdref rel in
-  let relargty =
-    let error () =
-      user_err_loc (constr_loc r,
-		    "Command.build_wellfounded",
-		    Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.")
-    in
-      try
-	let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in
-	  match ctx, kind_of_term ar with
-	  | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null)
-	      when Reductionops.is_conv env !evdref t u -> t
-	  | _, _ -> error ()
-      with e when CErrors.noncritical e -> error ()
-  in
-  let measure = interp_casted_constr_evars binders_env evdref measure relargty in
-  let wf_rel, wf_rel_fun, measure_fn =
-    let measure_body, measure =
-      it_mkLambda_or_LetIn measure letbinders,
-      it_mkLambda_or_LetIn measure binders
-    in
-    let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in
-    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
-    let wf_rel_fun x y =
-      mkApp (rel, [| subst1 x measure_body;
- 		     subst1 y measure_body |])
-    in wf_rel, wf_rel_fun, measure
-  in
-  let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
-  let argid' = Id.of_string (Id.to_string argname ^ "'") in
-  let wfarg len = LocalAssum (Name argid',
-                              mkSubset (Name argid') argtyp
-				       (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
-  in
-  let intern_bl = wfarg 1 :: [arg] in
-  let _intern_env = push_rel_context intern_bl env in
-  let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in
-  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
-  let projection = (* in wfarg :: arg :: before *)
-    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
-  in
-  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
-  let intern_arity = substl [projection] top_arity_let in
-  (* substitute the projection of wfarg for something,
-     now intern_arity is in wfarg :: arg *)
-  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in
-  let curry_fun =
-    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
-    let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in
-    let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
-    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
-    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
-    let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in
-    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
-    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
-      LocalDef (Name recname, body, ty)
-  in
-  let fun_bl = intern_fun_binder :: [arg] in
-  let lift_lets = Termops.lift_rel_context 1 letbinders in
-  let intern_body =
-    let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in
-    let (r, l, impls, scopes) =
-      Constrintern.compute_internalization_data env
-	Constrintern.Recursive full_arity impls 
-    in
-    let newimpls = Id.Map.singleton recname
-      (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))],
-       scopes @ [None]) in
-      interp_casted_constr_evars (push_rel_context ctx env) evdref
-        ~impls:newimpls body (lift 1 top_arity)
-  in
-  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
-  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
-  let def =
-    mkApp (Universes.constr_of_global (delayed_force fix_sub_ref),
-	  [| argtyp ; wf_rel ;
-	     Evarutil.e_new_evar env evdref
-	       ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof;
-	     prop |])
-  in
-  let def = Typing.e_solve_evars env evdref def in
-  let _ = evdref := Evarutil.nf_evar_map !evdref in
-  let def = mkApp (def, [|intern_body_lam|]) in
-  let binders_rel = nf_evar_context !evdref binders_rel in
-  let binders = nf_evar_context !evdref binders in
-  let top_arity = Evarutil.nf_evar !evdref top_arity in
-  let hook, recname, typ = 
-    if List.length binders_rel > 1 then
-      let name = add_suffix recname "_func" in
-      let hook l gr _ = 
-	let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in
-	let ty = it_mkProd_or_LetIn top_arity binders_rel in
-	let pl, univs = Evd.universe_context ?names:pl !evdref in
-	  (*FIXME poly? *)
-	let ce = definition_entry ~poly ~types:ty ~univs (Evarutil.nf_evar !evdref body) in
-	(** FIXME: include locality *)
-	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
-	let gr = ConstRef c in
-	  if Impargs.is_implicit_args () || not (List.is_empty impls) then
-	    Impargs.declare_manual_implicits false gr [impls]
-      in
-      let typ = it_mkProd_or_LetIn top_arity binders in
-	hook, name, typ
-    else 
-      let typ = it_mkProd_or_LetIn top_arity binders_rel in
-      let hook l gr _ = 
-	if Impargs.is_implicit_args () || not (List.is_empty impls) then
-	  Impargs.declare_manual_implicits false gr [impls]
-      in hook, recname, typ
-  in
-  let hook = Lemmas.mk_hook hook in
-  let fullcoqc = Evarutil.nf_evar !evdref def in
-  let fullctyp = Evarutil.nf_evar !evdref typ in
-  Obligations.check_evars env !evdref;
-  let evars, _, evars_def, evars_typ = 
-    Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp 
-  in
-  let ctx = Evd.evar_universe_context !evdref in
-    ignore(Obligations.add_definition recname ~term:evars_def ?pl
-	     evars_typ ctx evars ~hook)
-
-let interp_recursive isfix fixl notations =
-  let open Context.Named.Declaration in
-  let env = Global.env() in
-  let fixnames = List.map (fun fix -> fix.fix_name) fixl in
-
-  (* Interp arities allowing for unresolved types *)
-  let all_universes =
-    List.fold_right (fun sfe acc ->
-        match sfe.fix_univs , acc with
-        | None , acc -> acc
-        | x , None -> x
-        | Some ls , Some us ->
-	   if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then
-	     error "(co)-recursive definitions should all have the same universe binders";
-	   Some us) fixl None in
-  let ctx = Evd.make_evar_universe_context env all_universes in
-  let evdref = ref (Evd.from_ctx ctx) in
-  let fixctxs, fiximppairs, fixannots =
-    List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in
-  let fixctximpenvs, fixctximps = List.split fiximppairs in
-  let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
-  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
-  let fixtypes = List.map (nf_evar !evdref) fixtypes in
-  let fiximps = List.map3
-    (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps))
-    fixctximps fixcclimps fixctxs in
-  let rec_sign =
-    List.fold_left2
-      (fun env' id t ->
-	 if Flags.is_program_mode () then
-	   let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in
-	   let fixprot =
-	     try 
-	       let app = mkApp (delayed_force fix_proto, [|sort; t|]) in
-		 Typing.e_solve_evars env evdref app
-	     with e  when CErrors.noncritical e -> t
-	   in
-	     LocalAssum (id,fixprot) :: env'
-	 else LocalAssum (id,t) :: env')
-      [] fixnames fixtypes
-  in
-  let env_rec = push_named_context rec_sign env in
-
-  (* Get interpretation metadatas *)
-  let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in
-
-  (* Interp bodies with rollback because temp use of notations/implicit *)
-  let fixdefs =
-    Metasyntax.with_syntax_protection (fun () ->
-      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-      List.map4
-	(fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls))
-	fixctximpenvs fixctxs fixl fixccls)
-      () in
-
-  (* Instantiate evars and check all are resolved *)
-  let evd = solve_unif_constraints_with_heuristics env_rec !evdref in
-  let evd, nf = nf_evars_and_universes evd in
-  let fixdefs = List.map (Option.map nf) fixdefs in
-  let fixtypes = List.map nf fixtypes in
-  let fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in
-
-  (* Build the fix declaration block *)
-  (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots
-
-let check_recursive isfix env evd (fixnames,fixdefs,_) =
-  check_evars_are_solved env evd (Evd.empty,evd);
-  if List.for_all Option.has_some fixdefs then begin
-    let fixdefs = List.map Option.get fixdefs in
-    check_mutuality env isfix (List.combine fixnames fixdefs)
-  end
-
-let interp_fixpoint l ntns =
-  let (env,_,pl,evd),fix,info = interp_recursive true l ntns in
-  check_recursive true env evd fix;
-  (fix,pl,Evd.evar_universe_context evd,info)
-
-let interp_cofixpoint l ntns =
-  let (env,_,pl,evd),fix,info = interp_recursive false l ntns in
-  check_recursive false  env evd fix;
-  (fix,pl,Evd.evar_universe_context evd,info)
-    
-let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns =
-  if List.exists Option.is_empty fixdefs then
-    (* Some bodies to define by proof *)
-    let thms =
-      List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps))))
-		fixnames fixtypes fiximps in
-    let init_tac =
-      Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
-        fixdefs) in
-    let init_tac =
-      Option.map (List.map Proofview.V82.tactic) init_tac
-    in
-    let evd = Evd.from_ctx ctx in
-    Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint)
-      evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
-  else begin
-    (* We shortcut the proof process *)
-    let fixdefs = List.map Option.get fixdefs in
-    let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
-    let env = Global.env() in
-    let indexes = search_guard Loc.ghost env indexes fixdecls in
-    let fiximps = List.map (fun (n,r,p) -> r) fiximps in
-    let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in
-    let fixdecls =
-      List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
-    let evd = Evd.from_ctx ctx in
-    let evd = Evd.restrict_universe_context evd vars in
-    let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in
-    let pl, ctx = Evd.universe_context ?names:pl evd in
-    ignore (List.map4 (declare_fix (local, poly, Fixpoint) pl ctx)
-	      fixnames fixdecls fixtypes fiximps);
-    (* Declare the recursive definitions *)
-    fixpoint_message (Some indexes) fixnames;
-  end;
-  (* Declare notations *)
-  List.iter Metasyntax.add_notation_interpretation ntns
-
-let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns =
-  if List.exists Option.is_empty fixdefs then
-    (* Some bodies to define by proof *)
-    let thms =
-      List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps))))
-		fixnames fixtypes fiximps in
-    let init_tac =
-      Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
-        fixdefs) in
-    let init_tac =
-      Option.map (List.map Proofview.V82.tactic) init_tac
-    in
-    let evd = Evd.from_ctx ctx in
-      Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint)
-      evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
-  else begin
-    (* We shortcut the proof process *)
-    let fixdefs = List.map Option.get fixdefs in
-    let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
-    let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
-    let vars = Universes.universes_of_constr (List.hd fixdecls) in
-    let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in
-    let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in
-    let evd = Evd.from_ctx ctx in
-    let evd = Evd.restrict_universe_context evd vars in
-    let pl, ctx = Evd.universe_context ?names:pl evd in
-    ignore (List.map4 (declare_fix (local, poly, CoFixpoint) pl ctx) 
-	      fixnames fixdecls fixtypes fiximps);
-    (* Declare the recursive definitions *)
-    cofixpoint_message fixnames
-  end;
-  (* Declare notations *)
-  List.iter Metasyntax.add_notation_interpretation ntns
-
-let extract_decreasing_argument limit = function
-  | (na,CStructRec) -> na
-  | (na,_) when not limit -> na
-  | _ -> error 
-      "Only structural decreasing is supported for a non-Program Fixpoint"
-
-let extract_fixpoint_components limit l =
-  let fixl, ntnl = List.split l in
-  let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) ->
-    let ann = extract_decreasing_argument limit ann in
-      {fix_name = id; fix_annot = ann; fix_univs = pl;
-       fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
-  fixl, List.flatten ntnl
-
-let extract_cofixpoint_components l =
-  let fixl, ntnl = List.split l in
-  List.map (fun (((_,id),pl),bl,typ,def) ->
-	    {fix_name = id; fix_annot = None; fix_univs = pl;
-	     fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
-  List.flatten ntnl
-
-let out_def = function
-  | Some def -> def
-  | None -> error "Program Fixpoint needs defined bodies."
-
-let collect_evars_of_term evd c ty =
-  let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in
-  Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev))
-  evars (Evd.from_ctx (Evd.evar_universe_context evd))
-
-let do_program_recursive local p fixkind fixl ntns =
-  let isfix = fixkind != Obligations.IsCoFixpoint in
-  let (env, rec_sign, pl, evd), fix, info = 
-    interp_recursive isfix fixl ntns 
-  in
-    (* Program-specific code *)
-    (* Get the interesting evars, those that were not instanciated *)
-  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
-    (* Solve remaining evars *)
-  let evd = nf_evar_map_undefined evd in
-  let collect_evars id def typ imps =
-    (* Generalize by the recursive prototypes  *)
-    let def =
-      nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign)
-    and typ =
-      nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign)
-    in
-    let evm = collect_evars_of_term evd def typ in
-    let evars, _, def, typ = 
-      Obligations.eterm_obligations env id evm
-	(List.length rec_sign) def typ
-    in (id, def, typ, imps, evars)
-  in
-  let (fixnames,fixdefs,fixtypes) = fix in
-  let fiximps = List.map pi2 info in
-  let fixdefs = List.map out_def fixdefs in
-  let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in
-  let () = if isfix then begin
-      let possible_indexes = List.map compute_possible_guardness_evidences info in
-      let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
-	Array.of_list fixtypes,
-	Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
-      in
-      let indexes = 
-        Pretyping.search_guard
-          Loc.ghost (Global.env ()) possible_indexes fixdecls in
-      List.iteri (fun i _ ->
-          Inductive.check_fix env
-                              ((indexes,i),fixdecls))
-        fixl
-  end in
-  let ctx = Evd.evar_universe_context evd in
-  let kind = match fixkind with
-  | Obligations.IsFixpoint _ -> (local, p, Fixpoint)
-  | Obligations.IsCoFixpoint -> (local, p, CoFixpoint)
-  in
-  Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind
-
-let do_program_fixpoint local poly l =
-  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
-    match g, l with
-    | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] ->
-	let recarg = 
-	  match n with
-	  | Some n -> mkIdentC (snd n)
-	  | None ->
-	      errorlabstrm "do_program_fixpoint"
-		(str "Recursive argument required for well-founded fixpoints")
-	in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn
-	     
-    | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] ->
-	build_wellfounded (id, pl, n, bl, typ, out_def def) poly
-	  (Option.default (CRef (lt_ref,None)) r) m ntn
-	  
-    | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g ->
-	let fixl,ntns = extract_fixpoint_components true l in
-	let fixkind = Obligations.IsFixpoint g in
-	  do_program_recursive local poly fixkind fixl ntns
-
-    | _, _ ->
-	errorlabstrm "do_program_fixpoint"
-	  (str "Well-founded fixpoints not allowed in mutually recursive blocks")
-
-let check_safe () =
-  let open Declarations in
-  let flags = Environ.typing_flags (Global.env ()) in
-  flags.check_universes && flags.check_guarded
-
-let do_fixpoint local poly l =
-  if Flags.is_program_mode () then do_program_fixpoint local poly l
-  else
-    let fixl, ntns = extract_fixpoint_components true l in
-    let (_, _, _, info as fix) = interp_fixpoint fixl ntns in
-    let possible_indexes =
-      List.map compute_possible_guardness_evidences info in
-    declare_fixpoint local poly fix possible_indexes ntns;
-    if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
-
-let do_cofixpoint local poly l =
-  let fixl,ntns = extract_cofixpoint_components l in
-    if Flags.is_program_mode () then
-      do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns
-    else
-      let cofix = interp_cofixpoint fixl ntns in
-      declare_cofixpoint local poly cofix ntns;
-      if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
diff --git a/toplevel/command.mli b/toplevel/command.mli
deleted file mode 100644
index 616afb91..00000000
--- a/toplevel/command.mli
+++ /dev/null
@@ -1,176 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-open Entries
-open Libnames
-open Globnames
-open Vernacexpr
-open Constrexpr
-open Decl_kinds
-open Redexpr
-open Pfedit
-
-(** This file is about the interpretation of raw commands into typed
-    ones and top-level declaration of the main Gallina objects *)
-
-val do_universe : polymorphic -> Id.t Loc.located list -> unit
-val do_constraint : polymorphic ->
-  (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit
-
-(** {6 Hooks for Pcoq} *)
-
-val set_declare_definition_hook : (Safe_typing.private_constants definition_entry -> unit) -> unit
-val get_declare_definition_hook : unit -> (Safe_typing.private_constants definition_entry -> unit)
-
-(** {6 Definitions/Let} *)
-
-val interp_definition :
-  lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr ->
-  constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * 
-      Universes.universe_binders * Impargs.manual_implicits
-
-val declare_definition : Id.t -> definition_kind ->
-  Safe_typing.private_constants definition_entry -> Universes.universe_binders -> Impargs.manual_implicits ->
-    Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference
-
-val do_definition : Id.t -> definition_kind -> lident list option ->
-  local_binder list -> red_expr option -> constr_expr ->
-  constr_expr option -> unit Lemmas.declaration_hook -> unit
-
-(** {6 Parameters/Assumptions} *)
-
-(* val interp_assumption : env -> evar_map ref -> *)
-(*   local_binder list -> constr_expr ->  *)
-(*   types Univ.in_universe_context_set * Impargs.manual_implicits *)
-
-(** returns [false] if the assumption is neither local to a section,
-    nor in a module type and meant to be instantiated. *)
-val declare_assumption : coercion_flag -> assumption_kind -> 
-  types Univ.in_universe_context_set ->
-  Universes.universe_binders -> Impargs.manual_implicits ->
-  bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located ->
-  global_reference * Univ.Instance.t * bool
-
-val do_assumptions : locality * polymorphic * assumption_object_kind ->
-  Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool
-
-(* val declare_assumptions : variable Loc.located list -> *)
-(*   coercion_flag -> assumption_kind -> types Univ.in_universe_context_set ->  *)
-(*   Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *)
-
-(** {6 Inductive and coinductive types} *)
-
-(** Extracting the semantical components out of the raw syntax of mutual
-   inductive declarations *)
-
-type structured_one_inductive_expr = {
-  ind_name : Id.t;
-  ind_univs : lident list option;
-  ind_arity : constr_expr;
-  ind_lc : (Id.t * constr_expr) list
-}
-
-type structured_inductive_expr =
-  local_binder list * structured_one_inductive_expr list
-
-val extract_mutual_inductive_declaration_components :
-  (one_inductive_expr * decl_notation list) list ->
-    structured_inductive_expr * (*coercions:*) qualid list * decl_notation list
-
-(** Typing mutual inductive definitions *)
-
-type one_inductive_impls =
-  Impargs.manual_implicits (** for inds *)*
-  Impargs.manual_implicits list (** for constrs *)
-
-val interp_mutual_inductive :
-  structured_inductive_expr -> decl_notation list -> polymorphic ->
-    private_flag -> Decl_kinds.recursivity_kind ->
-    mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list
-
-(** Registering a mutual inductive definition together with its
-   associated schemes *)
-
-val declare_mutual_inductive_with_eliminations :
-  mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list ->
-  mutual_inductive
-
-(** Entry points for the vernacular commands Inductive and CoInductive *)
-
-val do_mutual_inductive :
-  (one_inductive_expr * decl_notation list) list -> polymorphic -> 
-  private_flag -> Decl_kinds.recursivity_kind -> unit
-
-(** {6 Fixpoints and cofixpoints} *)
-
-type structured_fixpoint_expr = {
-  fix_name : Id.t;
-  fix_univs : lident list option;
-  fix_annot : Id.t Loc.located option;
-  fix_binders : local_binder list;
-  fix_body : constr_expr option;
-  fix_type : constr_expr
-}
-
-(** Extracting the semantical components out of the raw syntax of
-   (co)fixpoints declarations *)
-
-val extract_fixpoint_components : bool ->
-  (fixpoint_expr * decl_notation list) list ->
-    structured_fixpoint_expr list * decl_notation list
-
-val extract_cofixpoint_components :
-  (cofixpoint_expr * decl_notation list) list ->
-    structured_fixpoint_expr list * decl_notation list
-
-(** Typing global fixpoints and cofixpoint_expr *)
-
-type recursive_preentry =
-  Id.t list * constr option list * types list
-
-val interp_fixpoint :
-  structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * lident list option * Evd.evar_universe_context * 
-    (Name.t list * Impargs.manual_implicits * int option) list
-
-val interp_cofixpoint :
-  structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * lident list option * Evd.evar_universe_context * 
-    (Name.t list * Impargs.manual_implicits * int option) list
-
-(** Registering fixpoints and cofixpoints in the environment *)
-
-val declare_fixpoint :
-  locality -> polymorphic ->
-  recursive_preentry * lident list option * Evd.evar_universe_context * 
-  (Name.t list * Impargs.manual_implicits * int option) list ->
-  lemma_possible_guards -> decl_notation list -> unit
-
-val declare_cofixpoint : locality -> polymorphic -> 
-  recursive_preentry * lident list option * Evd.evar_universe_context * 
-  (Name.t list * Impargs.manual_implicits * int option) list ->
-  decl_notation list -> unit
-
-(** Entry points for the vernacular commands Fixpoint and CoFixpoint *)
-
-val do_fixpoint :
-  (* When [false], assume guarded. *)
-  locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit
-
-val do_cofixpoint :
-  (* When [false], assume guarded. *)
-  locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit
-
-(** Utils *)
-
-val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit
-
-val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t ->
-  Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference
diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml
new file mode 100644
index 00000000..eacd1dcf
--- /dev/null
+++ b/toplevel/coqargs.ml
@@ -0,0 +1,584 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s))
+
+let fatal_error ?extra exn =
+  Topfmt.print_err_exn ?extra exn;
+  let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in
+  exit exit_code
+
+let error_missing_arg s =
+  prerr_endline ("Error: extra argument expected after option "^s);
+  prerr_endline "See -help for the syntax of supported options";
+  exit 1
+
+(******************************************************************************)
+(* Imperative effects! This must be fixed at some point.                      *)
+(******************************************************************************)
+let set_worker_id opt s =
+  assert (s <> "master");
+  Flags.async_proofs_worker_id := s
+
+let set_type_in_type () =
+  let typing_flags = Environ.typing_flags (Global.env ()) in
+  Global.set_typing_flags { typing_flags with Declarations.check_universes = false }
+
+(******************************************************************************)
+
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+type color = [`ON | `AUTO | `OFF]
+
+type coq_cmdopts = {
+
+  load_init   : bool;
+  load_rcfile : bool;
+  rcfile      : string option;
+
+  ml_includes : string list;
+  vo_includes : (string * Names.DirPath.t * bool) list;
+  vo_requires : (string * string option * bool option) list;
+  (* None = No Import; Some false = Import; Some true = Export *)
+
+  (* XXX: Fusion? *)
+  batch_mode : bool;
+  compilation_mode : compilation_mode;
+
+  toplevel_name : Names.DirPath.t;
+  toploop : string option;
+
+  compile_list: (string * bool) list;  (* bool is verbosity  *)
+  compilation_output_name : string option;
+
+  load_vernacular_list : (string * bool) list;
+
+  vio_checking: bool;
+  vio_tasks   : (int list * string) list;
+  vio_files   : string list;
+  vio_files_j : int;
+
+  color : color;
+
+  impredicative_set : Declarations.set_predicativity;
+  stm_flags   : Stm.AsyncOpts.stm_opt;
+  debug       : bool;
+  time        : bool;
+
+  filter_opts : bool;
+
+  glob_opt    : bool;
+
+  memory_stat : bool;
+  print_tags  : bool;
+  print_where : bool;
+  print_config: bool;
+  output_context : bool;
+
+  inputstate  : string option;
+  outputstate : string option;
+
+}
+
+let init_args = {
+
+  load_init   = true;
+  load_rcfile = true;
+  rcfile      = None;
+
+  ml_includes = [];
+  vo_includes = [];
+  vo_requires = [];
+
+  batch_mode = false;
+  compilation_mode = BuildVo;
+
+  toplevel_name = Names.(DirPath.make [Id.of_string "Top"]);
+  toploop = None;
+
+  compile_list = [];
+  compilation_output_name = None;
+
+  load_vernacular_list = [];
+
+  vio_checking = false;
+  vio_tasks    = [];
+  vio_files    = [];
+  vio_files_j  = 0;
+
+  color = `AUTO;
+
+  impredicative_set = Declarations.PredicativeSet;
+  stm_flags    = Stm.AsyncOpts.default_opts;
+  debug        = false;
+  time         = false;
+
+  filter_opts  = false;
+
+  glob_opt     = false;
+
+  memory_stat  = false;
+  print_tags   = false;
+  print_where  = false;
+  print_config = false;
+  output_context = false;
+
+  inputstate  = None;
+  outputstate = None;
+}
+
+(******************************************************************************)
+(* Functional arguments                                                       *)
+(******************************************************************************)
+let add_ml_include opts s =
+  { opts with ml_includes = s :: opts.ml_includes }
+
+let add_vo_include opts d p implicit =
+  let p = Libnames.dirpath_of_string p in
+  { opts with vo_includes = (d, p, implicit) :: opts.vo_includes }
+
+let add_vo_require opts d p export =
+  { opts with vo_requires = (d, p, export) :: opts.vo_requires }
+
+let add_compat_require opts v =
+  match v with
+  | Flags.V8_6 -> add_vo_require opts "Coq.Compat.Coq86" None (Some false)
+  | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false)
+  | Flags.Current -> add_vo_require opts "Coq.Compat.Coq88" None (Some false)
+
+let set_batch_mode opts =
+  Flags.quiet := true;
+  System.trust_file_cache := true;
+  { opts with batch_mode = true }
+
+let add_compile opts verbose s =
+  let opts = set_batch_mode opts in
+  if not opts.glob_opt then Dumpglob.dump_to_dotglob ();
+  (** make the file name explicit; needed not to break up Coq loadpath stuff. *)
+  let s =
+    let open Filename in
+    if is_implicit s
+    then concat current_dir_name s
+    else s
+  in
+  { opts with compile_list = (s,verbose) :: opts.compile_list }
+
+let add_load_vernacular opts verb s =
+  { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list }
+
+let add_vio_task opts f =
+  let opts = set_batch_mode opts in
+  { opts with vio_tasks = f :: opts.vio_tasks }
+
+let add_vio_file opts f =
+  let opts = set_batch_mode opts in
+  { opts with vio_files = f :: opts.vio_files }
+
+let set_vio_checking_j opts opt j =
+  try { opts with vio_files_j = int_of_string j }
+  with Failure _ ->
+    prerr_endline ("The first argument of " ^ opt ^ " must the number");
+    prerr_endline "of concurrent workers to be used (a positive integer).";
+    prerr_endline "Makefiles generated by coq_makefile should be called";
+    prerr_endline "setting the J variable like in 'make vio2vo J=3'";
+    exit 1
+
+(** Options for proof general *)
+let set_emacs opts =
+  if not (Option.is_empty opts.toploop) then
+    CErrors.user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop");
+  Coqloop.print_emacs := true;
+  Printer.enable_goal_tags_printing := true;
+  { opts with color = `OFF }
+
+let set_color opts = function
+| "yes" | "on" -> { opts with color = `ON }
+| "no" | "off" -> { opts with color = `OFF }
+| "auto" -> { opts with color = `AUTO }
+| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1
+
+let warn_deprecated_inputstate =
+  CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"
+         (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.")
+
+let set_inputstate opts s =
+  warn_deprecated_inputstate ();
+  { opts with inputstate = Some s }
+
+let warn_deprecated_outputstate =
+  CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
+         (fun () ->
+          Pp.strbrk "The outputstate option is deprecated and discouraged.")
+
+let set_outputstate opts s =
+  warn_deprecated_outputstate ();
+  { opts with outputstate = Some s }
+
+let exitcode opts = if opts.filter_opts then 2 else 0
+
+(******************************************************************************)
+(* Parsing helpers                                                            *)
+(******************************************************************************)
+let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
+
+let get_bool opt = function
+  | "yes" | "on" -> true
+  | "no" | "off" -> false
+  | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1
+
+let get_int opt n =
+  try int_of_string n
+  with Failure _ ->
+    prerr_endline ("Error: integer expected after option "^opt); exit 1
+
+let get_float opt n =
+  try float_of_string n
+  with Failure _ ->
+    prerr_endline ("Error: float expected after option "^opt); exit 1
+
+let get_host_port opt s =
+  match CString.split ':' s with
+  | [host; portr; portw] ->
+       Some (Spawned.Socket(host, int_of_string portr, int_of_string portw))
+  | ["stdfds"] -> Some Spawned.AnonPipe
+  | _ ->
+     prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt);
+     exit 1
+
+let get_error_resilience opt = function
+  | "on" | "all" | "yes" -> `All
+  | "off" | "no" -> `None
+  | s -> `Only (CString.split ',' s)
+
+let get_priority opt s =
+  try CoqworkmgrApi.priority_of_string s
+  with Invalid_argument _ ->
+    prerr_endline ("Error: low/high expected after "^opt); exit 1
+
+let get_async_proofs_mode opt = let open Stm.AsyncOpts in function
+  | "no" | "off" -> APoff
+  | "yes" | "on" -> APon
+  | "lazy" -> APonLazy
+  | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1
+
+let get_cache opt = function
+  | "force" -> Some Stm.AsyncOpts.Force
+  | _ -> prerr_endline ("Error: force expected after "^opt); exit 1
+
+let get_identifier opt s =
+  try Names.Id.of_string s
+  with CErrors.UserError _ ->
+    prerr_endline ("Error: valid identifier expected after option "^opt); exit 1
+
+let is_not_dash_option = function
+  | Some f when String.length f > 0 && f.[0] <> '-' -> true
+  | _ -> false
+
+let rec add_vio_args peek next oval =
+  if is_not_dash_option (peek ()) then
+    let oval = add_vio_file oval (next ()) in
+    add_vio_args peek next oval
+  else oval
+
+let get_native_name s =
+  (* We ignore even critical errors because this mode has to be super silent *)
+  try
+    String.concat "/" [Filename.dirname s;
+      Nativelib.output_dir; Library.native_name_from_filename s]
+  with _ -> ""
+
+(*s Parsing of the command line.
+    We no longer use [Arg.parse], in order to use share [Usage.print_usage]
+    between coqtop and coqc. *)
+
+let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesystem"
+    (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned")
+
+exception NoCoqLib
+
+let usage batch =
+  begin
+    try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib)
+    with NoCoqLib -> usage_no_coqlib ()
+  end;
+  let lp = Coqinit.toplevel_init_load_path () in
+  (* Necessary for finding the toplevels below *)
+  List.iter Mltop.add_coq_path lp;
+  if batch then Usage.print_usage_coqc ()
+  else begin
+    Mltop.load_ml_objects_raw_rex
+      (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
+    Usage.print_usage_coqtop ()
+  end
+
+(* Main parsing routine *)
+let parse_args arglist : coq_cmdopts * string list =
+  let args = ref arglist in
+  let extras = ref [] in
+  let rec parse oval = match !args with
+  | [] ->
+    (oval, List.rev !extras)
+  | opt :: rem ->
+    args := rem;
+    let next () = match !args with
+      | x::rem -> args := rem; x
+      | [] -> error_missing_arg opt
+    in
+    let peek_next () = match !args with
+      | x::_ -> Some x
+      | [] -> None
+    in
+    let noval = begin match opt with
+
+    (* Complex options with many args *)
+    |"-I"|"-include" ->
+      begin match rem with
+      | d :: rem ->
+        args := rem;
+        add_ml_include oval d
+      | [] -> error_missing_arg opt
+      end
+    |"-Q" ->
+      begin match rem with
+      | d :: p :: rem ->
+        args := rem;
+        add_vo_include oval d p false
+      | _ -> error_missing_arg opt
+      end
+    |"-R" ->
+      begin match rem with
+      | d :: p :: rem ->
+        args := rem;
+        add_vo_include oval d p true
+      | _ -> error_missing_arg opt
+      end
+
+    (* Options with two arg *)
+    |"-check-vio-tasks" ->
+      let tno = get_task_list (next ()) in
+      let tfile = next () in
+      add_vio_task oval (tno,tfile)
+
+    |"-schedule-vio-checking" ->
+      let oval = { oval with vio_checking = true } in
+      let oval = set_vio_checking_j oval opt (next ()) in
+      let oval = add_vio_file oval (next ()) in
+      add_vio_args peek_next next oval
+
+    |"-schedule-vio2vo" ->
+      let oval = set_vio_checking_j oval opt (next ()) in
+      let oval = add_vio_file oval (next ()) in
+      add_vio_args peek_next next oval
+
+    (* Options with one arg *)
+    |"-coqlib" ->
+      Flags.coqlib_spec := true;
+      Flags.coqlib := (next ());
+      oval
+
+    |"-async-proofs" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next())
+      }}
+    |"-async-proofs-j" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ()))
+      }}
+    |"-async-proofs-cache" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ())
+      }}
+
+    |"-async-proofs-tac-j" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_n_tacworkers = (get_int opt (next ()))
+      }}
+
+    |"-async-proofs-worker-priority" ->
+      WorkerLoop.async_proofs_worker_priority := get_priority opt (next ());
+      oval
+
+    |"-async-proofs-private-flags" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_private_flags = Some (next ());
+      }}
+
+    |"-async-proofs-tactic-error-resilience" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ())
+      }}
+
+    |"-async-proofs-command-error-resilience" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ())
+      }}
+
+    |"-async-proofs-delegation-threshold" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ())
+      }}
+
+    |"-worker-id" -> set_worker_id opt (next ()); oval
+
+    |"-compat" ->
+      let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in
+      Flags.compat_version := v;
+      add_compat_require oval v
+
+    |"-compile" ->
+      add_compile oval false (next ())
+
+    |"-compile-verbose" ->
+      add_compile oval true (next ())
+
+    |"-dump-glob" ->
+      Dumpglob.dump_into_file (next ());
+      { oval with glob_opt = true }
+
+    |"-feedback-glob" ->
+      Dumpglob.feedback_glob (); oval
+
+    |"-exclude-dir" ->
+      System.exclude_directory (next ()); oval
+
+    |"-init-file" ->
+      { oval with rcfile = Some (next ()); }
+
+    |"-inputstate"|"-is" ->
+      set_inputstate oval (next ())
+
+    |"-outputstate" ->
+      set_outputstate oval (next ())
+
+    |"-load-ml-object" ->
+      Mltop.dir_ml_load (next ()); oval
+
+    |"-load-ml-source" ->
+      Mltop.dir_ml_use (next ()); oval
+
+    |"-load-vernac-object" ->
+      add_vo_require oval (next ()) None None
+
+    |"-load-vernac-source"|"-l" ->
+      add_load_vernacular oval false (next ())
+
+    |"-load-vernac-source-verbose"|"-lv" ->
+      add_load_vernacular oval true (next ())
+
+    |"-mangle-names" ->
+      Namegen.set_mangle_names_mode (get_identifier opt (next ())); oval
+
+    |"-print-mod-uid" ->
+      let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
+
+    |"-profile-ltac-cutoff" ->
+      Flags.profile_ltac := true;
+      Flags.profile_ltac_cutoff := get_float opt (next ());
+      oval
+
+    |"-require" -> add_vo_require oval (next ()) None (Some false)
+
+    |"-top" ->
+      let topname = Libnames.dirpath_of_string (next ()) in
+      if Names.DirPath.is_empty topname then
+        CErrors.user_err Pp.(str "Need a non empty toplevel module name");
+      { oval with toplevel_name = topname }
+
+    |"-main-channel" ->
+      Spawned.main_channel := get_host_port opt (next()); oval
+
+    |"-control-channel" ->
+      Spawned.control_channel := get_host_port opt (next()); oval
+
+    |"-vio2vo" ->
+      let oval = add_compile oval false (next ()) in
+      { oval with compilation_mode = Vio2Vo }
+
+    |"-toploop" ->
+      if !Coqloop.print_emacs then
+        CErrors.user_err Pp.(str "Flags -toploop and -emacs are incompatible");
+      { oval with toploop = Some (next ()) }
+
+    |"-w" | "-W" ->
+      let w = next () in
+      if w = "none" then
+        (CWarnings.set_flags w; oval)
+      else
+        let w = CWarnings.get_flags () ^ "," ^ w in
+        CWarnings.set_flags (CWarnings.normalize_flags_string w);
+        oval
+
+    |"-o" -> { oval with compilation_output_name = Some (next()) }
+
+    (* Options with zero arg *)
+    |"-async-queries-always-delegate"
+    |"-async-proofs-always-delegate"
+    |"-async-proofs-full" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_full = true;
+      }}
+    |"-async-proofs-never-reopen-branch" ->
+      { oval with stm_flags = { oval.stm_flags with
+        Stm.AsyncOpts.async_proofs_never_reopen_branch = true
+      }}
+    |"-batch" -> set_batch_mode oval
+    |"-test-mode" -> Flags.test_mode := true; oval
+    |"-beautify" -> Flags.beautify := true; oval
+    |"-boot" -> Flags.boot := true; { oval with load_rcfile = false; }
+    |"-bt" -> Backtrace.record_backtrace true; oval
+    |"-color" -> set_color oval (next ())
+    |"-config"|"--config" -> { oval with print_config = true }
+    |"-debug" -> Coqinit.set_debug (); oval
+    |"-stm-debug" -> Stm.stm_debug := true; oval
+    |"-emacs" -> set_emacs oval
+    |"-filteropts" -> { oval with filter_opts = true }
+    |"-ideslave" ->
+      if !Coqloop.print_emacs then
+        CErrors.user_err Pp.(str "Flags -ideslave and -emacs are incompatible");
+      Flags.ide_slave := true;
+      { oval with toploop = Some "coqidetop" }
+
+    |"-impredicative-set" ->
+      { oval with impredicative_set = Declarations.ImpredicativeSet }
+    |"-indices-matter" -> Indtypes.enforce_indices_matter (); oval
+    |"-m"|"--memory" -> { oval with memory_stat = true }
+    |"-noinit"|"-nois" -> { oval with load_init = false }
+    |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true }
+    |"-native-compiler" ->
+      if not Coq_config.native_compiler then
+        warning "Native compilation was disabled at configure time."
+      else Flags.output_native_objects := true; oval
+    |"-output-context" -> { oval with output_context = true }
+    |"-profile-ltac" -> Flags.profile_ltac := true; oval
+    |"-q" -> { oval with load_rcfile = false; }
+    |"-quiet"|"-silent" ->
+      Flags.quiet := true;
+      Flags.make_warn false;
+      oval
+    |"-quick" -> { oval with compilation_mode = BuildVio }
+    |"-list-tags" -> { oval with print_tags = true }
+    |"-time" -> { oval with time = true }
+    |"-type-in-type" -> set_type_in_type (); oval
+    |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false)
+    |"-where" -> { oval with print_where = true }
+    |"-h"|"-H"|"-?"|"-help"|"--help" -> usage oval.batch_mode; oval
+    |"-v"|"--version" -> Usage.version (exitcode oval)
+    |"-print-version"|"--print-version" ->
+      Usage.machine_readable_version (exitcode oval)
+
+    (* Unknown option *)
+    | s ->
+      extras := s :: !extras;
+      oval
+    end in
+    parse noval
+  in
+  try
+    parse init_args
+  with any -> fatal_error any
diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli
new file mode 100644
index 00000000..de9b6a68
--- /dev/null
+++ b/toplevel/coqargs.mli
@@ -0,0 +1,65 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+type color = [`ON | `AUTO | `OFF]
+
+type coq_cmdopts = {
+
+  load_init   : bool;
+  load_rcfile : bool;
+  rcfile      : string option;
+
+  ml_includes : string list;
+  vo_includes : (string * Names.DirPath.t * bool) list;
+  vo_requires : (string * string option * bool option) list;
+
+  (* Fuse these two? Currently, [batch_mode] is only used to
+     distinguish coqc / coqtop in help display. *)
+  batch_mode : bool;
+  compilation_mode : compilation_mode;
+
+  toplevel_name : Names.DirPath.t;
+  toploop : string option;
+
+  compile_list: (string * bool) list;  (* bool is verbosity  *)
+  compilation_output_name : string option;
+
+  load_vernacular_list : (string * bool) list;
+
+  vio_checking: bool;
+  vio_tasks   : (int list * string) list;
+  vio_files   : string list;
+  vio_files_j : int;
+
+  color : color;
+
+  impredicative_set : Declarations.set_predicativity;
+  stm_flags   : Stm.AsyncOpts.stm_opt;
+  debug       : bool;
+  time        : bool;
+
+  filter_opts : bool;
+
+  glob_opt    : bool;
+
+  memory_stat : bool;
+  print_tags  : bool;
+  print_where : bool;
+  print_config: bool;
+  output_context : bool;
+
+  inputstate  : string option;
+  outputstate : string option;
+
+}
+
+val parse_args : string list -> coq_cmdopts * string list
+val exitcode : coq_cmdopts -> int
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index acbf909c..96a0bd5e 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -1,9 +1,11 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 open Util
@@ -20,21 +22,15 @@ let set_debug () =
   does not exist. *)
 
 let rcdefaultname = "coqrc"
-let rcfile = ref ""
-let rcfile_specified = ref false
-let set_rcfile s = rcfile := s; rcfile_specified := true
 
-let load_rc = ref true
-let no_load_rc () = load_rc := false
-
-let load_rcfile() =
-  if !load_rc then
+let load_rcfile ~rcfile ~time ~state =
     try
-      if !rcfile_specified then
-        if CUnix.file_readable_p !rcfile then
-          Vernac.load_vernac false !rcfile
-        else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
-      else
+      match rcfile with
+      | Some rcfile ->
+        if CUnix.file_readable_p rcfile then
+          Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state rcfile
+        else raise (Sys_error ("Cannot read rcfile: "^ rcfile))
+      | None ->
 	try
 	  let warn x = Feedback.msg_warning (str x) in
 	  let inferedrc = List.find CUnix.file_readable_p [
@@ -43,8 +39,8 @@ let load_rcfile() =
 	    Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version;
 	    Envars.home ~warn / "."^rcdefaultname
 	  ] in
-          Vernac.load_vernac false inferedrc
-	with Not_found -> ()
+          Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state inferedrc
+        with Not_found -> state
 	(*
 	Flags.if_verbose
 	  mSGNL (str ("No coqrc or coqrc."^Coq_config.version^
@@ -54,89 +50,79 @@ let load_rcfile() =
       let reraise = CErrors.push reraise in
       let () = Feedback.msg_info (str"Load of rcfile failed.") in
       iraise reraise
-  else
-    Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.")
 
 (* Recursively puts dir in the LoadPath if -nois was not passed *)
-let add_stdlib_path ~unix_path ~coq_root ~with_ml =
-  let add_ml = if with_ml then Mltop.AddRecML else Mltop.AddNoML in
-  Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:(!Flags.load_init)
-
-let add_userlib_path ~unix_path =
-  Mltop.add_rec_path Mltop.AddRecML ~unix_path
-    ~coq_root:Nameops.default_root_prefix ~implicit:false
-
-(* Options -I, -I-as, and -R of the command line *)
-let includes = ref []
-let push_include s alias implicit =
-  includes := (s, alias, implicit) :: !includes
-let ml_includes = ref []
-let push_ml_include s = ml_includes := s :: !ml_includes
-
-(* Initializes the LoadPath *)
-let init_load_path () =
+let build_stdlib_path ~load_init ~unix_path ~coq_path ~with_ml =
+  let open Mltop in
+  let add_ml = if with_ml then AddRecML else AddNoML in
+  { recursive = true;
+    path_spec = VoPath { unix_path; coq_path ; has_ml = add_ml; implicit = load_init }
+  }
+
+let build_userlib_path ~unix_path =
+  let open Mltop in
+  { recursive = true;
+    path_spec = VoPath {
+        unix_path;
+        coq_path = Libnames.default_root_prefix;
+        has_ml = Mltop.AddRecML;
+        implicit = false;
+      }
+  }
+
+let ml_path_if c p =
+  let open Mltop in
+  let f x = { recursive = false; path_spec = MlPath x } in
+  if c then List.map f p else []
+
+(* LoadPath for toploop toplevels *)
+let toplevel_init_load_path () =
+  let coqlib = Envars.coqlib () in
+  (* NOTE: These directories are searched from last to first *)
+  (* first, developer specific directory to open *)
+  ml_path_if Coq_config.local [coqlib/"dev"] @
+
+  (* main loops *)
+  ml_path_if (Coq_config.local || !Flags.boot) [coqlib/"stm"; coqlib/"ide"] @
+  ml_path_if (System.exists_dir (coqlib/"toploop")) [coqlib/"toploop"]
+
+(* LoadPath for Coq user libraries *)
+let libs_init_load_path ~load_init =
+
+  let open Mltop in
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
   let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in
   let coqpath = Envars.coqpath in
-  let coq_root = Names.DirPath.make [Nameops.coq_root] in
-    (* NOTE: These directories are searched from last to first *)
-    (* first, developer specific directory to open *)
-    if Coq_config.local then
-      Mltop.add_ml_dir (coqlib/"dev");
-    (* main loops *)
-    if Coq_config.local || !Flags.boot then begin
-      Mltop.add_ml_dir (coqlib/"stm");
-      Mltop.add_ml_dir (coqlib/"ide")
-    end;
-    if System.exists_dir (coqlib/"toploop") then
-      Mltop.add_ml_dir (coqlib/"toploop");
-    (* then standard library *)
-    add_stdlib_path ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false;
-    (* then plugins *)
-    add_stdlib_path ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true;
-    (* then user-contrib *)
-    if Sys.file_exists user_contrib then
-      add_userlib_path ~unix_path:user_contrib;
-    (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
-    List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs;
-    (* then directories in COQPATH *)
-    List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath;
-    (* then current directory (not recursively!) *)
-    Mltop.add_ml_dir ".";
-    Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false;
-    (* additional loadpath, given with options -Q and -R *)
-    List.iter
-      (fun (unix_path, coq_root, implicit) ->
-        Mltop.add_rec_path Mltop.AddNoML ~unix_path ~coq_root ~implicit)
-      (List.rev !includes);
-    (* additional ml directories, given with option -I *)
-    List.iter Mltop.add_ml_dir (List.rev !ml_includes)
-
-let init_library_roots () =
-  includes := []
+  let coq_path = Names.DirPath.make [Libnames.coq_root] in
+
+  (* then standard library and plugins *)
+  [build_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_path ~with_ml:false;
+   build_stdlib_path ~load_init ~unix_path:(coqlib/"plugins")  ~coq_path ~with_ml:true ] @
+
+  (* then user-contrib *)
+  (if Sys.file_exists user_contrib then
+     [build_userlib_path ~unix_path:user_contrib] else []
+  ) @
+
+  (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *)
+  List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) @
+
+  (* then current directory (not recursively!) *)
+  [ { recursive = false;
+      path_spec = VoPath { unix_path = ".";
+                           coq_path = Libnames.default_root_prefix;
+                           implicit = false;
+                           has_ml = AddTopML }
+    } ]
 
 (* Initialises the Ocaml toplevel before launching it, so that it can
    find the "include" file in the *source* directory *)
 let init_ocaml_path () =
+  let open Mltop in
+  let lp s = { recursive = false; path_spec = MlPath s } in
   let add_subdir dl =
-    Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl)
+    Mltop.add_coq_path (lp (List.fold_left (/) Envars.coqroot [dl]))
   in
-    Mltop.add_ml_dir (Envars.coqlib ());
-    List.iter add_subdir
-      [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
-	[ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
-	[ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ];
-        [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ]
-
-let get_compat_version = function
-  | "8.6" -> Flags.Current
-  | "8.5" -> Flags.V8_5
-  | "8.4" -> Flags.V8_4
-  | "8.3" -> Flags.V8_3
-  | "8.2" -> Flags.V8_2
-  | ("8.1" | "8.0") as s ->
-    CErrors.errorlabstrm "get_compat_version"
-      (str "Compatibility with version " ++ str s ++ str " not supported.")
-  | s -> CErrors.errorlabstrm "get_compat_version"
-      (str "Unknown compatibility version \"" ++ str s ++ str "\".")
+    Mltop.add_coq_path (lp (Envars.coqlib ()));
+    List.iter add_subdir Coq_config.all_src_dirs
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index 4ff87628..71b5523c 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -1,28 +1,23 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 (** Initialization. *)
 
 val set_debug : unit -> unit
 
-val set_rcfile : string -> unit
-
-val no_load_rc : unit -> unit
-val load_rcfile : unit -> unit
-
-val push_include : string -> Names.DirPath.t -> bool -> unit
-(** [push_include phys_path log_path implicit] *)
-
-val push_ml_include : string -> unit
-
-val init_load_path : unit -> unit
-val init_library_roots : unit -> unit
+val load_rcfile : rcfile:(string option) -> time:bool -> state:Vernac.State.t -> Vernac.State.t
 
 val init_ocaml_path : unit -> unit
 
-val get_compat_version : string -> Flags.compat_version
+(* LoadPath for toploop toplevels *)
+val toplevel_init_load_path : unit ->  Mltop.coq_path list
+
+(* LoadPath for Coq user libraries *)
+val libs_init_load_path : load_init:bool -> Mltop.coq_path list
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index e9771cfa..3239d360 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -1,36 +1,36 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 open Pp
-open CErrors
-open Util
-open Flags
-open Vernac
-open Pcoq
 
-let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x
+let print_emacs = ref false
+
+let top_stderr x =
+  Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x
 
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
 type input_buffer = {
-  mutable prompt : unit -> string;
-  mutable str : string; (* buffer of already read characters *)
+  mutable prompt : Stm.doc -> string;
+  mutable str : Bytes.t; (* buffer of already read characters *)
   mutable len : int;    (* number of chars in the buffer *)
   mutable bols : int list; (* offsets in str of beginning of lines *)
-  mutable tokens : Gram.coq_parsable; (* stream of tokens *)
+  mutable tokens : Pcoq.Gram.coq_parsable; (* stream of tokens *)
   mutable start : int } (* stream count of the first char of the buffer *)
 
 (* Double the size of the buffer. *)
 
-let resize_buffer ibuf =
-  let nstr = String.create (2 * String.length ibuf.str + 1) in
-  String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
+let resize_buffer ibuf = let open Bytes in
+  let nstr = create (2 * length ibuf.str + 1) in
+  blit ibuf.str 0 nstr 0 (length ibuf.str);
   ibuf.str <- nstr
 
 (* Delete all irrelevant lines of the input buffer. Keep the last line
@@ -40,7 +40,7 @@ let resynch_buffer ibuf =
   match ibuf.bols with
     | ll::_ ->
         let new_len = ibuf.len - ll in
-        String.blit ibuf.str ll ibuf.str 0 new_len;
+        Bytes.blit ibuf.str ll ibuf.str 0 new_len;
         ibuf.len <- new_len;
         ibuf.bols <- [];
         ibuf.start <- ibuf.start + ll
@@ -49,24 +49,22 @@ let resynch_buffer ibuf =
 
 (* emacs special prompt tag for easy detection. No special character,
    to avoid interfering with utf8. Compatibility code removed. *)
-
-let emacs_prompt_startstring() = Printer.emacs_str "<prompt>"
-
-let emacs_prompt_endstring() = Printer.emacs_str "</prompt>"
+let emacs_prompt_startstring () = if !print_emacs then "<prompt>"  else ""
+let emacs_prompt_endstring   () = if !print_emacs then "</prompt>" else ""
 
 (* Read a char in an input channel, displaying a prompt at every
    beginning of line. *)
-let prompt_char ic ibuf count =
+let prompt_char doc ic ibuf count =
   let bol = match ibuf.bols with
     | ll::_ -> Int.equal ibuf.len ll
     | [] -> Int.equal ibuf.len 0
   in
-  if bol && not !print_emacs then top_stderr (str (ibuf.prompt()));
+  if bol && not !print_emacs then top_stderr (str (ibuf.prompt doc));
   try
     let c = input_char ic in
     if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
-    if ibuf.len == String.length ibuf.str then resize_buffer ibuf;
-    ibuf.str.[ibuf.len] <- c;
+    if ibuf.len == Bytes.length ibuf.str then resize_buffer ibuf;
+    Bytes.set ibuf.str ibuf.len c;
     ibuf.len <- ibuf.len + 1;
     Some c
   with End_of_file ->
@@ -74,21 +72,22 @@ let prompt_char ic ibuf count =
 
 (* Reinitialize the char stream (after a Drop) *)
 
-let reset_input_buffer ic ibuf =
-  ibuf.str <- "";
+let reset_input_buffer doc ic ibuf =
+  ibuf.str <- Bytes.empty;
   ibuf.len <- 0;
   ibuf.bols <- [];
-  ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf));
+  ibuf.tokens <- Pcoq.Gram.parsable (Stream.from (prompt_char doc ic ibuf));
   ibuf.start <- 0
 
 (* Functions to print underlined locations from an input buffer. *)
+module TopErr = struct
 
 (* Given a location, returns the list of locations of each line. The last
    line is returned separately. It also checks the location bounds. *)
 
 let get_bols_of_loc ibuf (bp,ep) =
   let add_line (b,e) lines =
-    if b < 0 || e < b then anomaly (Pp.str "Bad location");
+    if b < 0 || e < b then CErrors.anomaly (Pp.str "Bad location.");
     match lines with
       | ([],None) -> ([], Some (b,e))
       | (fl,oe) -> ((b,e)::fl, oe)
@@ -109,86 +108,93 @@ let dotted_location (b,e) =
   else
     (String.make (e-b-1) '.', " ")
 
-let blanch_utf8_string s bp ep =
-  let s' = String.make (ep-bp) ' ' in
+let blanch_utf8_string s bp ep = let open Bytes in
+  let s' = make (ep-bp) ' ' in
   let j = ref 0 in
   for i = bp to ep - 1 do
-    let n = Char.code s.[i] in
+    let n = Char.code (get s i) in
     (* Heuristic: assume utf-8 chars are printed using a single
     fixed-size char and therefore contract all utf-8 code into one
     space; in any case, preserve tabulation so
     that its effective interpretation in terms of spacing is preserved *)
-    if s.[i] == '\t' then s'.[!j] <- '\t';
+    if get s i == '\t' then set s' !j '\t';
     if n < 0x80 || 0xC0 <= n then incr j
   done;
-  String.sub s' 0 !j
+  Bytes.sub_string s' 0 !j
+
+let adjust_loc_buf ib loc = let open Loc in
+  { loc with ep = loc.ep - ib.start; bp = loc.bp - ib.start }
 
 let print_highlight_location ib loc =
   let (bp,ep) = Loc.unloc loc in
-  let bp = bp - ib.start
-  and ep = ep - ib.start in
   let highlight_lines =
     match get_bols_of_loc ib (bp,ep) with
       | ([],(bl,el)) ->
 	  let shift = blanch_utf8_string ib.str bl bp in
 	  let span = String.length (blanch_utf8_string ib.str bp ep) in
-	  (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
+	  (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++
            str"> " ++ str(shift) ++ str(String.make span '^'))
       | ((b1,e1)::ml,(bn,en)) ->
           let (d1,s1) = dotted_location (b1,bp) in
           let (dn,sn) = dotted_location (ep,en) in
           let l1 = (str"> " ++ str d1 ++ str s1 ++
-                      str(String.sub ib.str bp (e1-bp))) in
+                      str(Bytes.sub_string ib.str bp (e1-bp))) in
           let li =
             prlist (fun (bi,ei) ->
-                      (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
-          let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
+                      (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in
+          let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++
                       str sn ++ str dn) in
 	  (l1 ++ li ++ ln)
   in
-  let loc  = Loc.make_loc (bp,ep) in
-  (Pp.pr_loc loc ++ highlight_lines ++ fnl ())
-
-(* Functions to report located errors in a file. *)
-
-let print_location_in_file loc =
-  let fname = loc.Loc.fname in
-  let errstrm = str"Error while reading " ++ str fname in
-  if Loc.is_ghost loc then
-    hov 1 (errstrm ++ spc() ++ str" (unknown location):") ++ fnl ()
-  else
-    let errstrm = mt ()
-      (* if String.equal outer_fname fname then mt() else errstrm ++ str":" ++ fnl() *)
-    in
-    let open Loc in
-    hov 0 (* No line break so as to follow emacs error message format *)
-	(errstrm ++ Pp.pr_loc loc)
+  highlight_lines
 
 let valid_buffer_loc ib loc =
-  not (Loc.is_ghost loc) &&
   let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e
 
+(* Toplevel error explanation. *)
+let error_info_for_buffer ?loc buf =
+  Option.map (fun loc ->
+      let fname = loc.Loc.fname in
+      let hl, loc =
+        (* We are in the toplevel *)
+        match fname with
+        | Loc.ToplevelInput ->
+          let nloc = adjust_loc_buf buf loc in
+          if valid_buffer_loc buf loc then
+            (fnl () ++ print_highlight_location buf nloc, nloc)
+            (* in the toplevel, but not a valid buffer *)
+          else (mt (), nloc)
+          (* we are in batch mode, don't adjust location *)
+        | Loc.InFile _ ->
+           (mt (), loc)
+      in Topfmt.pr_loc loc ++ hl
+    ) loc
+
+(* Actual printing routine *)
+let print_error_for_buffer ?loc lvl msg buf =
+  let pre_hdr = error_info_for_buffer ?loc buf in
+  if !print_emacs
+  then Topfmt.emacs_logger ?pre_hdr lvl msg
+  else Topfmt.std_logger   ?pre_hdr lvl msg
+
+(*
+let print_toplevel_parse_error (e, info) buf =
+  let loc = Loc.get_loc info in
+  let lvl = Feedback.Error in
+  let msg = CErrors.iprint (e, info) in
+  print_error_for_buffer ?loc lvl msg buf
+*)
+end
+
 (*s The Coq prompt is the name of the focused proof, if any, and "Coq"
     otherwise. We trap all exceptions to prevent the error message printing
     from cycling. *)
 let make_prompt () =
   try
-    (Names.Id.to_string (Pfedit.get_current_proof_name ())) ^ " < "
+    (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < "
   with Proof_global.NoCurrentProof ->
     "Coq < "
 
-(*let build_pending_list l =
-  let pl = ref ">" in
-  let l' = ref l in
-  let res =
-    while List.length !l' > 1 do
-      pl := !pl ^ "|" Names.Id.to_string x;
-      l':=List.tl !l'
-    done in
-  let last = try List.hd !l' with _ ->   in
-  "<"^l'
-*)
-
 (* the coq prompt added to the default one when in emacs mode
    The prompt contains the current state label [n] (for global
    backtracking) and the current proof state [p] (for proof
@@ -197,70 +203,50 @@ let make_prompt () =
 
    "n |lem1|lem2|lem3| p < "
 *)
-let make_emacs_prompt() =
-  let statnum = Stateid.to_string (Stm.get_current_state ()) in
-  let dpth = Stm.current_proof_depth() in
-  let pending = Stm.get_all_proof_names() in
+let make_emacs_prompt doc =
+  let statnum = Stateid.to_string (Stm.get_current_state ~doc) in
+  let dpth = Stm.current_proof_depth ~doc in
+  let pending = Stm.get_all_proof_names ~doc in
   let pendingprompt =
     List.fold_left
-      (fun acc x -> acc ^ (if String.is_empty acc then "" else "|") ^ Names.Id.to_string x)
+      (fun acc x -> acc ^ (if CString.is_empty acc then "" else "|") ^ Names.Id.to_string x)
       "" pending in
   let proof_info = if dpth >= 0 then string_of_int dpth else "0" in
-  if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
+  if !print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
   else ""
 
 (* A buffer to store the current command read on stdin. It is
  * initialized when a vernac command is immediately followed by "\n",
  * or after a Drop. *)
 let top_buffer =
-  let pr() =
+  let pr doc =
     emacs_prompt_startstring()
     ^ make_prompt()
-    ^ make_emacs_prompt()
+    ^ make_emacs_prompt doc
     ^ emacs_prompt_endstring()
   in
   { prompt = pr;
-    str = "";
+    str = Bytes.empty;
     len = 0;
     bols = [];
-    tokens = Gram.parsable (Stream.of_list []);
+    tokens = Pcoq.Gram.parsable (Stream.of_list []);
     start = 0 }
 
 let set_prompt prompt =
   top_buffer.prompt
-  <- (fun () ->
+  <- (fun doc ->
     emacs_prompt_startstring()
     ^ prompt ()
     ^ emacs_prompt_endstring())
 
-(* The following exceptions need not be located. *)
-
-let locate_exn = function
-  | Out_of_memory | Stack_overflow | Sys.Break -> false
-  | _ -> true
-
-(* Toplevel error explanation. *)
-
-let print_toplevel_error (e, info) =
-  let loc = Option.default Loc.ghost (Loc.get_loc info) in
-  let fname = loc.Loc.fname in
-  let locmsg =
-    if Loc.is_ghost loc || String.equal fname "" then
-      if locate_exn e && valid_buffer_loc top_buffer loc then
-	print_highlight_location top_buffer loc
-      else mt ()
-    else print_location_in_file loc
-  in
-  locmsg ++ CErrors.iprint (e, info)
-
 (* Read the input stream until a dot is encountered *)
 let parse_to_dot =
-  let rec dot st = match Compat.get_tok (Stream.next st) with
+  let rec dot st = match Stream.next st with
     | Tok.KEYWORD ("."|"...") -> ()
-    | Tok.EOI -> raise End_of_input
+    | Tok.EOI -> raise Stm.End_of_input
     | _ -> dot st
   in
-  Gram.Entry.of_parser "Coqtoplevel.dot" dot
+  Pcoq.Gram.Entry.of_parser "Coqtoplevel.dot" dot
 
 (* If an error occurred while parsing, we try to read the input until a dot
    token is encountered.
@@ -268,20 +254,56 @@ let parse_to_dot =
 
 let rec discard_to_dot () =
   try
-    Gram.entry_parse parse_to_dot top_buffer.tokens
+    Pcoq.Gram.entry_parse parse_to_dot top_buffer.tokens
   with
-    | Compat.Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
-    | End_of_input -> raise End_of_input
+    | Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
+    | Stm.End_of_input -> raise Stm.End_of_input
     | e when CErrors.noncritical e -> ()
 
-let read_sentence input =
-  try
-    let (loc, _ as r) = Vernac.parse_sentence input in
-    CWarnings.set_current_loc loc; r
+let read_sentence ~state input =
+  let open Vernac.State in
+  try Stm.parse_sentence ~doc:state.doc state.sid input
   with reraise ->
     let reraise = CErrors.push reraise in
     discard_to_dot ();
-    iraise reraise
+    (* The caller of read_sentence does the error printing now, this
+       should be re-enabled once we rely on the feedback error
+       printer again *)
+    (* TopErr.print_toplevel_parse_error reraise top_buffer; *)
+    Exninfo.iraise reraise
+
+let extract_default_loc loc doc_id sid : Loc.t option =
+  match loc with
+  | Some _ -> loc
+  | None ->
+    try
+      let doc = Stm.get_doc doc_id in
+      Option.cata fst None Stm.(get_ast ~doc sid)
+    with _ -> loc
+
+(** Coqloop Console feedback handler *)
+let coqloop_feed (fb : Feedback.feedback) = let open Feedback in
+  match fb.contents with
+  | Processed   -> ()
+  | Incomplete  -> ()
+  | Complete    -> ()
+  | ProcessingIn _ -> ()
+  | InProgress _ -> ()
+  | WorkerStatus (_,_) -> ()
+  | AddedAxiom  -> ()
+  | GlobRef (_,_,_,_,_) -> ()
+  | GlobDef (_,_,_,_) -> ()
+  | FileDependency (_,_) -> ()
+  | FileLoaded (_,_) -> ()
+  | Custom (_,_,_) -> ()
+  (* Re-enable when we switch back to feedback-based error printing *)
+  | Message (Error,loc,msg) -> ()
+  (* TopErr.print_error_for_buffer ?loc lvl msg top_buffer *)
+  | Message (Warning,loc,msg) ->
+    let loc = extract_default_loc loc fb.doc_id fb.span_id in
+    TopErr.print_error_for_buffer ?loc Warning msg top_buffer
+  | Message (lvl,loc,msg) ->
+    TopErr.print_error_for_buffer ?loc lvl msg top_buffer
 
 (** [do_vernac] reads and executes a toplevel phrase, and print error
     messages when an exception is raised, except for the following:
@@ -293,24 +315,29 @@ let read_sentence input =
     is caught and handled (i.e. not re-raised).
 *)
 
-let do_vernac () =
+let do_vernac ~time ~state =
+  let open Vernac.State in
   top_stderr (fnl());
-  if !print_emacs then top_stderr (str (top_buffer.prompt()));
+  if !print_emacs then top_stderr (str (top_buffer.prompt state.doc));
   resynch_buffer top_buffer;
   try
     let input = (top_buffer.tokens, None) in
-    Vernac.process_expr top_buffer.tokens (read_sentence input)
+    Vernac.process_expr ~time ~state (read_sentence ~state (fst input))
   with
-    | End_of_input | CErrors.Quit ->
+    | Stm.End_of_input | CErrors.Quit ->
         top_stderr (fnl ()); raise CErrors.Quit
     | CErrors.Drop ->  (* Last chance *)
         if Mltop.is_ocaml_top() then raise CErrors.Drop
-        else Feedback.msg_error (str"There is no ML toplevel.")
+        else (Feedback.msg_warning (str "There is no ML toplevel."); state)
+    (* Exception printing should be done by the feedback listener,
+       however this is not yet ready so we rely on the exception for
+       now. *)
     | any ->
-        let any = CErrors.push any in
-        let msg = print_toplevel_error any ++ fnl () in
-        pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg;
-        Format.pp_print_flush !Pp_control.std_ft ()
+      let (e, info) = CErrors.push any in
+      let loc = Loc.get_loc info in
+      let msg = CErrors.iprint (e, info) in
+      TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer;
+      state
 
 (** Main coq loop : read vernacular expressions until Drop is entered.
     Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
@@ -318,37 +345,77 @@ let do_vernac () =
     exit the loop are Drop and Quit. Any other exception there indicates
     an issue with [print_toplevel_error] above. *)
 
-(*
-let feed_emacs = function
-  | { Interface.id = Interface.State id;
-      Interface.content = Interface.GlobRef (_,a,_,c,_) }  -> 
-    prerr_endline ("<info>" ^"<id>"^Stateid.to_string id ^"</id>"
-		   ^a^" "^c^ "</info>")
-  | _  -> ()
-*)
-
 (* Flush in a compatible order with 8.5 *)
 (* This mimics the semantics of the old Pp.flush_all *)
 let loop_flush_all () =
   Pervasives.flush stderr;
   Pervasives.flush stdout;
-  Format.pp_print_flush !Pp_control.std_ft ();
-  Format.pp_print_flush !Pp_control.err_ft ()
+  Format.pp_print_flush !Topfmt.std_ft ();
+  Format.pp_print_flush !Topfmt.err_ft ()
+
+let pr_open_cur_subgoals () =
+  try
+    let proof = Proof_global.give_me_the_proof () in
+    Printer.pr_open_subgoals ~proof
+  with Proof_global.NoCurrentProof -> Pp.str ""
+
+(* Goal equality heuristic. *)
+let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2
+let evleq e1 e2 = CList.equal Evar.equal e1 e2
+let cproof p1 p2 =
+  let (a1,a2,a3,a4,_),(b1,b2,b3,b4,_) = Proof.proof p1, Proof.proof p2 in
+  evleq a1 b1 &&
+  CList.equal (pequal evleq evleq) a2 b2 &&
+  CList.equal Evar.equal a3 b3 &&
+  CList.equal Evar.equal a4 b4
+
+(* We try to behave better when goal printing raises an exception
+   [usually Ctrl-C]
+
+   This is mostly a hack as we should protect printing in a more
+   generic way, but that'll do for now *)
+let top_goal_print oldp newp =
+  try
+    let proof_changed = not (Option.equal cproof oldp newp) in
+    let print_goals = not !Flags.quiet &&
+                      proof_changed && Proof_global.there_are_pending_proofs () in
+    if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ())
+  with
+  | CErrors.Drop | CErrors.Quit as exn -> raise exn
+  | exn ->
+    let (e, info) = CErrors.push exn in
+    let loc = Loc.get_loc info in
+    let msg = CErrors.iprint (e, info) in
+    TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer
+
+let drop_last_doc = ref None
 
-let rec loop () =
+let rec loop ~time ~state =
+  let open Vernac.State in
   Sys.catch_break true;
-  if !Flags.print_emacs then Vernacentries.qed_display_script := false;
-  Flags.coqtop_ui := true;
   try
-    reset_input_buffer stdin top_buffer;
-    while true do do_vernac(); loop_flush_all () done
+    reset_input_buffer state.doc stdin top_buffer;
+    (* Be careful to keep this loop tail-recursive *)
+    let rec vernac_loop ~state =
+      let nstate = do_vernac ~time ~state in
+      top_goal_print state.proof nstate.proof;
+      loop_flush_all ();
+      vernac_loop ~state:nstate
+    in vernac_loop ~state
   with
-    | CErrors.Drop -> ()
+    | CErrors.Drop ->
+      (* Due to using exceptions as a form of control, state here goes
+         out of sync as [do_vernac] will never return. We must thus do
+         this hack until we make `Drop` a toplevel-only command. See
+         bug #6872. *)
+      let state = { state with sid = Stm.get_current_state ~doc:state.doc } in
+      drop_last_doc := Some state;
+      state
     | CErrors.Quit -> exit 0
     | any ->
-      Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++
-                str (Printexc.to_string any) ++
-                fnl() ++
-                str"Please report" ++
-                strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
-      loop ()
+      top_stderr (str "Anomaly: main loop exited with exception: " ++
+                  str (Printexc.to_string any) ++
+                  fnl() ++
+                  str"Please report" ++
+                  strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
+      loop ~time ~state
diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli
index e40353e0..bbb9b138 100644
--- a/toplevel/coqloop.mli
+++ b/toplevel/coqloop.mli
@@ -1,21 +1,24 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Pp
-
 (** The Coq toplevel loop. *)
 
+(** -emacs option: printing includes emacs tags. *)
+val print_emacs : bool ref
+
 (** A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
 type input_buffer = {
-  mutable prompt : unit -> string;
-  mutable str : string; (** buffer of already read characters *)
+  mutable prompt : Stm.doc -> string;
+  mutable str : Bytes.t; (** buffer of already read characters *)
   mutable len : int;    (** number of chars in the buffer *)
   mutable bols : int list; (** offsets in str of begining of lines *)
   mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *)
@@ -26,16 +29,14 @@ type input_buffer = {
 val top_buffer : input_buffer
 val set_prompt : (unit -> string) -> unit
 
-(** Toplevel error explanation, dealing with locations, Drop, Ctrl-D
-  May raise only the following exceptions: [Drop] and [End_of_input],
-  meaning we get out of the Coq loop. *)
-
-val print_toplevel_error : Exninfo.iexn -> std_ppcmds
+(** Toplevel feedback printer. *)
+val coqloop_feed : Feedback.feedback -> unit
 
 (** Parse and execute one vernac command. *)
-
-val do_vernac : unit -> unit
+val do_vernac : time:bool -> state:Vernac.State.t -> Vernac.State.t
 
 (** Main entry point of Coq: read and execute vernac commands. *)
+val loop : time:bool -> state:Vernac.State.t -> Vernac.State.t
 
-val loop : unit -> unit
+(** Last document seen after `Drop` *)
+val drop_last_doc : Vernac.State.t option ref
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index d9f8ed88..943b66f6 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -1,19 +1,15 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 open Pp
-open CErrors
-open Util
-open Flags
-open Names
-open Libnames
-open States
-open Coqinit
+open Coqargs
 
 let () = at_exit flush_all
 
@@ -34,64 +30,31 @@ let print_header () =
   Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")");
   flush_all ()
 
-let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s)
+let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s))
 
-let toploop = ref None
+(* Feedback received in the init stage, this is different as the STM
+   will not be generally be initialized, thus stateid, etc... may be
+   bogus. For now we just print to the console too *)
+let coqtop_init_feed = Coqloop.coqloop_feed
 
-let color : [`ON | `AUTO | `OFF] ref = ref `AUTO
-let set_color = function
-| "yes" | "on" -> color := `ON
-| "no" | "off" -> color := `OFF
-| "auto" -> color := `AUTO
-| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1
-
-let init_color () =
-  let has_color = match !color with
-  | `OFF -> false
-  | `ON -> true
-  | `AUTO ->
-    Terminal.has_style Unix.stdout &&
-    Terminal.has_style Unix.stderr &&
-    (* emacs compilation buffer does not support colors by default,
-       its TERM variable is set to "dumb". *)
-    try Sys.getenv "TERM" <> "dumb" with Not_found -> false
-  in
-  if has_color then begin
-    let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
-    match colors with
-    | None ->
-      (** Default colors *)
-      Feedback.init_color_output ()
-    | Some "" ->
-      (** No color output *)
-      ()
-    | Some s ->
-      (** Overwrite all colors *)
-      Ppstyle.clear_styles ();
-      Ppstyle.parse_config s;
-      Feedback.init_color_output ()
-  end
-
-let toploop_init = ref begin fun x ->
-  let () = init_color () in
-  let () = CoqworkmgrApi.(init !Flags.async_proofs_worker_priority) in
-  x
-  end
-
-let toploop_run = ref (fun () ->
+(* Default toplevel loop *)
+let console_toploop_run opts ~state =
+  (* We initialize the console only if we run the toploop_run *)
+  let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in
   if Dumpglob.dump () then begin
-    if_verbose warning "Dumpglob cannot be used in interactive mode.";
+    Flags.if_verbose warning "Dumpglob cannot be used in interactive mode.";
     Dumpglob.noglob ()
   end;
-  Coqloop.loop();
+  let _ = Coqloop.loop ~time:opts.time ~state in
   (* Initialise and launch the Ocaml toplevel *)
   Coqinit.init_ocaml_path();
-  Mltop.ocaml_toploop())
+  Mltop.ocaml_toploop();
+  (* We let the feeder in place for users of Drop *)
+  Feedback.del_feeder tl_feed
 
-let output_context = ref false
+let toploop_run = ref console_toploop_run
 
 let memory_stat = ref false
-
 let print_memory_stat () =
   begin (* -m|--memory from the command-line *)
     if !memory_stat then
@@ -111,151 +74,319 @@ let print_memory_stat () =
 
 let _ = at_exit print_memory_stat
 
-let impredicative_set = ref Declarations.PredicativeSet
-let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet
-let set_type_in_type () =
-  let typing_flags = Environ.typing_flags (Global.env ()) in
-  Global.set_typing_flags { typing_flags with Declarations.check_universes = false }
-let engage () =
-  Global.set_engagement !impredicative_set
-
-let set_batch_mode () = batch_mode := true
-
-let toplevel_default_name = DirPath.make [Id.of_string "Top"]
-let toplevel_name = ref (Some toplevel_default_name)
-let set_toplevel_name dir =
-  if DirPath.is_empty dir then error "Need a non empty toplevel module name";
-  toplevel_name := Some dir
-let unset_toplevel_name () = toplevel_name := None
-
-let remove_top_ml () = Mltop.remove ()
-
-let warn_deprecated_inputstate =
-  CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"
-         (fun () -> strbrk "The inputstate option is deprecated and discouraged.")
-
-let inputstate = ref ""
-let set_inputstate s =
-  warn_deprecated_inputstate ();
-  inputstate:=s
-let inputstate () =
-  if not (String.is_empty !inputstate) then
-    let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in
-    intern_state fname
-
-let warn_deprecated_outputstate =
-  CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
-         (fun () ->
-          strbrk "The outputstate option is deprecated and discouraged.")
-
-let outputstate = ref ""
-let set_outputstate s =
-  warn_deprecated_outputstate ();
-  outputstate:=s
-let outputstate () =
-  if not (String.is_empty !outputstate) then
-    let fname = CUnix.make_suffix !outputstate ".coq" in
-    extern_state fname
-
-let set_include d p implicit =
-  let p = dirpath_of_string p in
-  push_include d p implicit
-
-let load_vernacular_list = ref ([] : (string * bool) list)
-let add_load_vernacular verb s =
-  load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list
-let load_vernacular () =
-  List.iter
-    (fun (s,b) ->
-      let s = Loadpath.locate_file s in
-      if !Flags.beautify then
-	with_option beautify_file (Vernac.load_vernac b) s
-      else
-	Vernac.load_vernac b s)
-    (List.rev !load_vernacular_list)
-
-let load_vernacular_obj = ref ([] : string list)
-let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj
-let load_vernac_obj () =
-  let map dir = Qualid (Loc.ghost, qualid_of_string dir) in
-  Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj)
-
-let require_prelude () =
-  let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in
-  let vio = Envars.coqlib () / "theories/Init/Prelude.vio" in
-  let m =
-    if Sys.file_exists vo then vo else
-    if Sys.file_exists vio then vio else vo in
-  Library.require_library_from_dirpath [Coqlib.prelude_module,m] (Some true)
-
-let require_list = ref ([] : string list)
-let add_require s = require_list := s :: !require_list
-let require () =
-  let () = if !load_init then silently require_prelude () in
-  let map dir = Qualid (Loc.ghost, qualid_of_string dir) in
-  Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list)
-
-let add_compat_require v =
-  match v with
-  | Flags.V8_4 -> add_require "Coq.Compat.Coq84"
-  | Flags.V8_5 -> add_require "Coq.Compat.Coq85"
-  | _ -> ()
-
-let compile_list = ref ([] : (bool * string) list)
-
-let glob_opt = ref false
-
-let add_compile verbose s =
-  set_batch_mode ();
-  Flags.make_silent true;
-  if not !glob_opt then Dumpglob.dump_to_dotglob ();
-  (** make the file name explicit; needed not to break up Coq loadpath stuff. *)
-  let s =
-    let open Filename in
-    if is_implicit s
-    then concat current_dir_name s
-    else s
+(******************************************************************************)
+(* Input/Output State                                                         *)
+(******************************************************************************)
+let inputstate opts =
+  Option.iter (fun istate_file ->
+    let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in
+    States.intern_state fname) opts.inputstate
+
+let outputstate opts =
+  Option.iter (fun ostate_file ->
+    let fname = CUnix.make_suffix ostate_file ".coq" in
+    States.extern_state fname) opts.outputstate
+
+(******************************************************************************)
+(* Interactive Load File Simulation                                           *)
+(******************************************************************************)
+let load_vernacular opts ~state =
+  List.fold_left
+    (fun state (f_in, echo) ->
+      let s = Loadpath.locate_file f_in in
+      (* Should make the beautify logic clearer *)
+      let load_vernac f = Vernac.load_vernac ~time:opts.time ~echo ~interactive:false ~check:true ~state f in
+      if !Flags.beautify
+      then Flags.with_option Flags.beautify_file load_vernac f_in
+      else load_vernac s
+    ) state (List.rev opts.load_vernacular_list)
+
+let load_init_vernaculars opts ~state =
+  let state = if opts.load_rcfile then
+      Coqinit.load_rcfile ~rcfile:opts.rcfile ~time:opts.time ~state
+    else begin
+      Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.");
+      state
+    end in
+
+  load_vernacular opts ~state
+
+(******************************************************************************)
+(* Startup LoadPath and Modules                                               *)
+(******************************************************************************)
+(* prelude_data == From Coq Require Export Prelude. *)
+let prelude_data = "Prelude", Some "Coq", Some true
+
+let require_libs opts =
+  if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires
+
+let cmdline_load_path opts =
+  let open Mltop in
+  (* loadpaths given by options -Q and -R *)
+  List.map
+    (fun (unix_path, coq_path, implicit) ->
+       { recursive = true;
+         path_spec = VoPath { unix_path; coq_path; has_ml = Mltop.AddNoML; implicit } })
+      (List.rev opts.vo_includes) @
+
+  (* additional ml directories, given with option -I *)
+  List.map (fun s -> {recursive = false; path_spec = MlPath s}) (List.rev opts.ml_includes)
+
+let build_load_path opts =
+  Coqinit.libs_init_load_path ~load_init:opts.load_init @
+  cmdline_load_path opts
+
+(******************************************************************************)
+(* Fatal Errors                                                               *)
+(******************************************************************************)
+
+(** Prints info which is either an error or an anomaly and then exits
+    with the appropriate error code *)
+let fatal_error msg =
+  Topfmt.std_logger Feedback.Error msg;
+  flush_all ();
+  exit 1
+
+let fatal_error_exn ?extra exn =
+  Topfmt.print_err_exn ?extra exn;
+  flush_all ();
+  let exit_code =
+    if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1
   in
-  compile_list := (verbose,s) :: !compile_list
+  exit exit_code
+
+(******************************************************************************)
+(* File Compilation                                                           *)
+(******************************************************************************)
+let warn_file_no_extension =
+  CWarnings.create ~name:"file-no-extension" ~category:"filesystem"
+         (fun (f,ext) ->
+          str "File \"" ++ str f ++
+            strbrk "\" has been implicitly expanded to \"" ++
+            str f ++ str ext ++ str "\"")
+
+let ensure_ext ext f =
+  if Filename.check_suffix f ext then f
+  else begin
+    warn_file_no_extension (f,ext);
+    f ^ ext
+  end
 
-let compile_file (v,f) =
+let chop_extension f =
+  try Filename.chop_extension f with _ -> f
+
+let ensure_bname src tgt =
+  let src, tgt = Filename.basename src, Filename.basename tgt in
+  let src, tgt = chop_extension src, chop_extension tgt in
+  if src <> tgt then
+    fatal_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++
+                   str "Source: " ++ str src                                                ++ fnl () ++
+                   str "Target: " ++ str tgt)
+
+let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt
+
+let ensure_v v = ensure ".v" v v
+let ensure_vo v vo = ensure ".vo" v vo
+let ensure_vio v vio = ensure ".vio" v vio
+
+let ensure_exists f =
+  if not (Sys.file_exists f) then
+    fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f))
+
+(* Compile a vernac file *)
+let compile opts ~echo ~f_in ~f_out =
+  let open Vernac.State in
+  let check_pending_proofs () =
+    let pfs = Proof_global.get_all_proof_names () in
+    if not (CList.is_empty pfs) then
+      fatal_error (str "There are pending proofs: "
+                    ++ (pfs
+                        |> List.rev
+                        |> prlist_with_sep pr_comma Names.Id.print)
+                    ++ str ".")
+  in
+  let iload_path = build_load_path opts in
+  let require_libs = require_libs opts in
+  let stm_options = opts.stm_flags in
+  match opts.compilation_mode with
+  | BuildVo ->
+      Flags.record_aux_file := true;
+      let long_f_dot_v = ensure_v f_in in
+      ensure_exists long_f_dot_v;
+      let long_f_dot_vo =
+        match f_out with
+        | None -> long_f_dot_v ^ "o"
+        | Some f -> ensure_vo long_f_dot_v f in
+
+      let doc, sid = Stm.(new_doc
+          { doc_type = VoDoc long_f_dot_vo;
+            iload_path; require_libs; stm_options;
+          }) in
+
+      let state = { doc; sid; proof = None } in
+      let state = load_init_vernaculars opts ~state in
+      let ldir = Stm.get_ldir ~doc:state.doc in
+      Aux_file.(start_aux_file
+        ~aux_file:(aux_file_name_for long_f_dot_vo)
+        ~v_file:long_f_dot_v);
+      Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
+      Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
+      let wall_clock1 = Unix.gettimeofday () in
+      let state = Vernac.load_vernac ~time:opts.time ~echo ~check:true ~interactive:false ~state long_f_dot_v in
+      let _doc = Stm.join ~doc:state.doc in
+      let wall_clock2 = Unix.gettimeofday () in
+      check_pending_proofs ();
+      Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ());
+      Aux_file.record_in_aux_at "vo_compile_time"
+        (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
+      Aux_file.stop_aux_file ();
+      Dumpglob.end_dump_glob ()
+
+  | BuildVio ->
+      Flags.record_aux_file := false;
+      Dumpglob.noglob ();
+
+      let long_f_dot_v = ensure_v f_in in
+      ensure_exists long_f_dot_v;
+
+      let long_f_dot_vio =
+        match f_out with
+        | None -> long_f_dot_v ^ "io"
+        | Some f -> ensure_vio long_f_dot_v f in
+
+      (* We need to disable error resiliency, otherwise some errors
+         will be ignored in batch mode. c.f. #6707
+
+         This is not necessary in the vo case as it fully checks the
+         document anyways. *)
+      let stm_options = let open Stm.AsyncOpts in
+        { stm_options with
+          async_proofs_cmd_error_resilience = false;
+          async_proofs_tac_error_resilience = `None;
+        } in
+
+      let doc, sid = Stm.(new_doc
+          { doc_type = VioDoc long_f_dot_vio;
+            iload_path; require_libs; stm_options;
+          }) in
+
+      let state = { doc; sid; proof = None } in
+      let state = load_init_vernaculars opts ~state in
+      let ldir = Stm.get_ldir ~doc:state.doc in
+      let state = Vernac.load_vernac ~time:opts.time ~echo ~check:false ~interactive:false ~state long_f_dot_v in
+      let doc = Stm.finish ~doc:state.doc in
+      check_pending_proofs ();
+      let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in
+      Stm.reset_task_queue ()
+
+  | Vio2Vo ->
+      let open Filename in
+      Flags.record_aux_file := false;
+      Dumpglob.noglob ();
+      let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in
+      let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in
+      let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
+      Library.save_library_raw lfdv sum lib univs proofs
+
+let compile opts ~echo ~f_in ~f_out =
+  ignore(CoqworkmgrApi.get 1);
+  compile opts ~echo ~f_in ~f_out;
+  CoqworkmgrApi.giveback 1
+
+let compile_file opts (f_in, echo) =
+  let f_out = opts.compilation_output_name in
   if !Flags.beautify then
-    with_option beautify_file (Vernac.compile v) f
+    Flags.with_option Flags.beautify_file
+      (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in
   else
-    Vernac.compile v f
+    compile opts ~echo ~f_in ~f_out
 
-let compile_files () =
-  if !compile_list == [] then ()
-  else
-    let init_state = States.freeze ~marshallable:`No in
-    Feedback.(add_feeder debug_feeder);
-    List.iter (fun vf ->
-        States.unfreeze init_state;
-        compile_file vf)
-      (List.rev !compile_list)
+let compile_files opts =
+  let compile_list = List.rev opts.compile_list in
+  List.iter (compile_file opts) compile_list
 
-(** Options for proof general *)
-
-let set_emacs () =
-  if not (Option.is_empty !toploop) then
-    error "Flag -emacs is incompatible with a custom toplevel loop";
-  Flags.print_emacs := true;
-  Feedback.(set_logger emacs_logger);
-  Vernacentries.qed_display_script := false;
-  color := `OFF
-
-(** Options for CoqIDE *)
+(******************************************************************************)
+(* VIO Dispatching                                                            *)
+(******************************************************************************)
+let check_vio_tasks opts =
+  let rc =
+    List.fold_left (fun acc t -> Vio_checking.check_vio t && acc)
+      true (List.rev opts.vio_tasks) in
+  if not rc then fatal_error Pp.(str "VIO Task Check failed")
 
-let set_ideslave () =
-  if !Flags.print_emacs then error "Flags -ideslave and -emacs are incompatible";
-  toploop := Some "coqidetop";
-  Flags.ide_slave := true
+(* vio files *)
+let schedule_vio opts =
+  if opts.vio_checking then
+    Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files
+  else
+    Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files
+
+let do_vio opts =
+  (* We must initialize the loadpath here as the vio scheduling
+     process happens outside of the STM *)
+  if opts.vio_files <> [] || opts.vio_tasks <> [] then
+    let iload_path = build_load_path opts in
+    List.iter Mltop.add_coq_path iload_path;
+
+  (* Vio compile pass *)
+  if opts.vio_files <> [] then schedule_vio opts;
+  (* Vio task pass *)
+  if opts.vio_tasks <> [] then check_vio_tasks opts
+
+
+(******************************************************************************)
+(* Color Options                                                              *)
+(******************************************************************************)
+let init_color color_mode =
+  let has_color = match color_mode with
+  | `OFF -> false
+  | `ON -> true
+  | `AUTO ->
+    Terminal.has_style Unix.stdout &&
+    Terminal.has_style Unix.stderr &&
+    (* emacs compilation buffer does not support colors by default,
+       its TERM variable is set to "dumb". *)
+    try Sys.getenv "TERM" <> "dumb" with Not_found -> false
+  in
+  if has_color then begin
+    let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
+    match colors with
+    | None ->
+      (** Default colors *)
+      Topfmt.default_styles ();
+      Topfmt.init_terminal_output ~color:true
+    | Some "" ->
+      (** No color output *)
+      Topfmt.init_terminal_output ~color:false
+    | Some s ->
+      (** Overwrite all colors *)
+      Topfmt.parse_color_config s;
+      Topfmt.init_terminal_output ~color:true
+  end
+  else
+    Topfmt.init_terminal_output ~color:false
 
-(** Options for slaves *)
+let toploop_init = ref begin fun opts x ->
+  let () = init_color opts.color in
+  let () = CoqworkmgrApi.init !WorkerLoop.async_proofs_worker_priority in
+  x
+  end
 
-let set_toploop name =
-  if !Flags.print_emacs then error "Flags -toploop and -emacs are incompatible";
-  toploop := Some name
+let print_style_tags opts =
+  let () = init_color opts.color in
+  let tags = Topfmt.dump_tags () in
+  let iter (t, st) =
+    let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in
+    print_string opt
+  in
+  let make (t, st) =
+    let tags = List.map string_of_int (Terminal.repr st) in
+    (t ^ "=" ^ String.concat ";" tags)
+  in
+  let repr = List.map make tags in
+  let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in
+  let () = List.iter iter tags in
+  flush_all ()
 
 (** GC tweaking *)
 
@@ -282,389 +413,112 @@ let init_gc () =
              Gc.minor_heap_size = 33554432; (** 4M *)
              Gc.space_overhead = 120}
 
-(*s Parsing of the command line.
-    We no longer use [Arg.parse], in order to use share [Usage.print_usage]
-    between coqtop and coqc. *)
-
-let usage () =
-  Envars.set_coqlib CErrors.error;
-  init_load_path ();
-  if !batch_mode then Usage.print_usage_coqc ()
-  else begin
-    Mltop.load_ml_objects_raw_rex
-      (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
-    Usage.print_usage_coqtop ()
-  end
-
-let print_style_tags () =
-  let () = init_color () in
-  let tags = Ppstyle.dump () in
-  let iter (t, st) =
-    let st = match st with Some st -> st | None -> Terminal.make () in
-    let opt =
-      Terminal.eval st ^
-      String.concat "." (Ppstyle.repr t) ^
-      Terminal.reset ^ "\n"
-    in
-    print_string opt
-  in
-  let make (t, st) = match st with
-  | None -> None
-  | Some st ->
-    let tags = List.map string_of_int (Terminal.repr st) in
-    let t = String.concat "." (Ppstyle.repr t) in
-    Some (t ^ "=" ^ String.concat ";" tags)
-  in
-  let repr = List.map_filter make tags in
-  let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in
-  let () = List.iter iter tags in
-  flush_all ()
-
-let error_missing_arg s =
-  prerr_endline ("Error: extra argument expected after option "^s);
-  prerr_endline "See -help for the syntax of supported options";
-  exit 1
-
-let filter_opts = ref false
-let exitcode () = if !filter_opts then 2 else 0
-
-let print_where = ref false
-let print_config = ref false
-let print_tags = ref false
-
-let get_priority opt s =
-  try Flags.priority_of_string s
-  with Invalid_argument _ ->
-    prerr_endline ("Error: low/high expected after "^opt); exit 1
-
-let get_async_proofs_mode opt = function
-  | "no" | "off" -> Flags.APoff
-  | "yes" | "on" -> Flags.APon
-  | "lazy" -> Flags.APonLazy
-  | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1
-
-let get_cache opt = function
-  | "force" -> Some Flags.Force
-  | _ -> prerr_endline ("Error: force expected after "^opt); exit 1
-
-
-let set_worker_id opt s =
-  assert (s <> "master");
-  Flags.async_proofs_worker_id := s
-
-let get_bool opt = function
-  | "yes" | "on" -> true
-  | "no" | "off" -> false
-  | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1
-
-let get_int opt n =
-  try int_of_string n
-  with Failure _ ->
-    prerr_endline ("Error: integer expected after option "^opt); exit 1
-
-let get_float opt n =
-  try float_of_string n
-  with Failure _ ->
-    prerr_endline ("Error: float expected after option "^opt); exit 1
-
-let get_host_port opt s =
-  match CString.split ':' s with
-  | [host; portr; portw] ->
-       Some (Spawned.Socket(host, int_of_string portr, int_of_string portw))
-  | ["stdfds"] -> Some Spawned.AnonPipe
-  | _ ->
-     prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt);
-     exit 1
-
-let get_error_resilience opt = function
-  | "on" | "all" | "yes" -> `All
-  | "off" | "no" -> `None
-  | s -> `Only (String.split ',' s)
-
-let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
-
-let vio_tasks = ref []
-
-let add_vio_task f =
-  set_batch_mode ();
-  Flags.make_silent true;
-  vio_tasks := f :: !vio_tasks
-
-let check_vio_tasks () =
-  let rc =
-    List.fold_left (fun acc t -> Vio_checking.check_vio t && acc)
-      true (List.rev !vio_tasks) in
-  if not rc then exit 1
-
-let vio_files = ref []
-let vio_files_j = ref 0
-let vio_checking = ref false
-let add_vio_file f =
-  set_batch_mode ();
-  Flags.make_silent true;
-  vio_files := f :: !vio_files
-
-let set_vio_checking_j opt j =
-  try vio_files_j := int_of_string j
-  with Failure _ ->
-    prerr_endline ("The first argument of " ^ opt ^ " must the number");
-    prerr_endline "of concurrent workers to be used (a positive integer).";
-    prerr_endline "Makefiles generated by coq_makefile should be called";
-    prerr_endline "setting the J variable like in 'make vio2vo J=3'";
-    exit 1
-
-let is_not_dash_option = function
-  | Some f when String.length f > 0 && f.[0] <> '-' -> true
-  | _ -> false
-
-let schedule_vio_checking () =
-  if !vio_files <> [] && !vio_checking then
-    Vio_checking.schedule_vio_checking !vio_files_j !vio_files
-let schedule_vio_compilation () =
-  if !vio_files <> [] && not !vio_checking then
-    Vio_checking.schedule_vio_compilation !vio_files_j !vio_files
-
-let get_native_name s =
-  (* We ignore even critical errors because this mode has to be super silent *)
-  try
-    String.concat "/" [Filename.dirname s;
-      Nativelib.output_dir; Library.native_name_from_filename s]
-  with _ -> ""
-
-let parse_args arglist =
-  let args = ref arglist in
-  let extras = ref [] in
-  let rec parse () = match !args with
-  | [] -> List.rev !extras
-  | opt :: rem ->
-    args := rem;
-    let next () = match !args with
-      | x::rem -> args := rem; x
-      | [] -> error_missing_arg opt
-    in
-    let peek_next () = match !args with
-      | x::_ -> Some x
-      | [] -> None
-    in
-    begin match opt with
-
-    (* Complex options with many args *)
-    |"-I"|"-include" ->
-      begin match rem with
-      | d :: rem -> push_ml_include d; args := rem
-      | [] -> error_missing_arg opt
-      end
-    |"-Q" ->
-      begin match rem with
-      | d :: p :: rem -> set_include d p false; args := rem
-      | _ -> error_missing_arg opt
-      end
-    |"-R" ->
-      begin match rem with
-      | d :: p :: rem -> set_include d p true; args := rem
-      | _ -> error_missing_arg opt
-      end
-
-    (* Options with two arg *)
-    |"-check-vio-tasks" ->
-        let tno = get_task_list (next ()) in
-        let tfile = next () in
-        add_vio_task (tno,tfile)
-    |"-schedule-vio-checking" ->
-        vio_checking := true;
-        set_vio_checking_j opt (next ());
-        add_vio_file (next ());
-        while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
-    |"-schedule-vio2vo" ->
-        set_vio_checking_j opt (next ());
-        add_vio_file (next ());
-        while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
-
-    (* Options with one arg *)
-    |"-coqlib" -> Flags.coqlib_spec:=true; Flags.coqlib:=(next ())
-    |"-async-proofs" ->
-        Flags.async_proofs_mode := get_async_proofs_mode opt (next())
-    |"-async-proofs-j" ->
-        Flags.async_proofs_n_workers := (get_int opt (next ()))
-    |"-async-proofs-cache" ->
-        Flags.async_proofs_cache := get_cache opt (next ())
-    |"-async-proofs-tac-j" ->
-        Flags.async_proofs_n_tacworkers := (get_int opt (next ()))
-    |"-async-proofs-worker-priority" ->
-        Flags.async_proofs_worker_priority := get_priority opt (next ())
-    |"-async-proofs-private-flags" ->
-        Flags.async_proofs_private_flags := Some (next ());
-    |"-async-proofs-tactic-error-resilience" ->
-        Flags.async_proofs_tac_error_resilience := get_error_resilience opt (next ())
-    |"-async-proofs-command-error-resilience" ->
-        Flags.async_proofs_cmd_error_resilience := get_bool opt (next ())
-    |"-async-proofs-delegation-threshold" ->
-        Flags.async_proofs_delegation_threshold:= get_float opt (next ())
-    |"-worker-id" -> set_worker_id opt (next ())
-    |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v
-    |"-compile" -> add_compile false (next ())
-    |"-compile-verbose" -> add_compile true (next ())
-    |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true
-    |"-feedback-glob" -> Dumpglob.feedback_glob ()
-    |"-exclude-dir" -> System.exclude_directory (next ())
-    |"-init-file" -> set_rcfile (next ())
-    |"-inputstate"|"-is" -> set_inputstate (next ())
-    |"-load-ml-object" -> Mltop.dir_ml_load (next ())
-    |"-load-ml-source" -> Mltop.dir_ml_use (next ())
-    |"-load-vernac-object" -> add_vernac_obj (next ())
-    |"-load-vernac-source"|"-l" -> add_load_vernacular false (next ())
-    |"-load-vernac-source-verbose"|"-lv" -> add_load_vernacular true (next ())
-    |"-outputstate" -> set_outputstate (next ())
-    |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
-    |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; Flags.profile_ltac_cutoff := get_float opt (next ())
-    |"-require" -> add_require (next ())
-    |"-top" -> set_toplevel_name (dirpath_of_string (next ()))
-    |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ())
-    |"-main-channel" -> Spawned.main_channel := get_host_port opt (next())
-    |"-control-channel" -> Spawned.control_channel := get_host_port opt (next())
-    |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo
-    |"-toploop" -> set_toploop (next ())
-    |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ()))
-    |"-o" -> Flags.compilation_output_name := Some (next())
-
-    (* Options with zero arg *)
-    |"-async-queries-always-delegate"
-    |"-async-proofs-always-delegate"
-    |"-async-proofs-full" ->
-        Flags.async_proofs_full := true;
-    |"-async-proofs-never-reopen-branch" ->
-        Flags.async_proofs_never_reopen_branch := true;
-    |"-batch" -> set_batch_mode ()
-    |"-test-mode" -> test_mode := true
-    |"-beautify" -> beautify := true
-    |"-boot" -> boot := true; no_load_rc ()
-    |"-bt" -> Backtrace.record_backtrace true
-    |"-color" -> set_color (next ())
-    |"-config"|"--config" -> print_config := true
-    |"-debug" -> set_debug ()
-    |"-emacs" -> set_emacs ()
-    |"-filteropts" -> filter_opts := true
-    |"-h"|"-H"|"-?"|"-help"|"--help" -> usage ()
-    |"-ideslave" -> set_ideslave ()
-    |"-impredicative-set" -> set_impredicative_set ()
-    |"-indices-matter" -> Indtypes.enforce_indices_matter ()
-    |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6"
-    |"-m"|"--memory" -> memory_stat := true
-    |"-noinit"|"-nois" -> load_init := false
-    |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true
-    |"-native-compiler" ->
-      if Coq_config.no_native_compiler then
-	warning "Native compilation was disabled at configure time."
-      else native_compiler := true
-    |"-notop" -> unset_toplevel_name ()
-    |"-output-context" -> output_context := true
-    |"-profile-ltac" -> Flags.profile_ltac := true
-    |"-q" -> no_load_rc ()
-    |"-quiet"|"-silent" -> Flags.make_silent true; Flags.make_warn false
-    |"-quick" -> Flags.compilation_mode := BuildVio
-    |"-list-tags" -> print_tags := true
-    |"-time" -> Flags.time := true
-    |"-type-in-type" -> set_type_in_type ()
-    |"-unicode" -> add_require "Utf8_core"
-    |"-v"|"--version" -> Usage.version (exitcode ())
-    |"--print-version" -> Usage.machine_readable_version (exitcode ())
-    |"-where" -> print_where := true
-    |"-xml" -> Flags.xml_export := true
-
-    (* Deprecated options *)
-    |"-byte" -> warning "option -byte deprecated, call with .byte suffix"
-    |"-opt" -> warning "option -opt deprecated, call with .opt suffix"
-    |"-full" -> warning "option -full deprecated"
-    |"-notactics" -> warning "Obsolete option \"-notactics\"."; remove_top_ml ()
-    |"-emacs-U" ->
-      warning "Obsolete option \"-emacs-U\", use -emacs instead."; set_emacs ()
-    |"-v7" -> error "This version of Coq does not support v7 syntax"
-    |"-v8" -> warning "Obsolete option \"-v8\"."
-    |"-lazy-load-proofs" -> warning "Obsolete option \"-lazy-load-proofs\"."
-    |"-dont-load-proofs" -> warning "Obsolete option \"-dont-load-proofs\"."
-    |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"."
-    |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ())
-    |"-quality" -> warning "Obsolete option \"-quality\"."
-
-    (* Unknown option *)
-    | s -> extras := s :: !extras
-    end;
-    parse ()
-  in
-  try
-    parse ()
-  with
-    | UserError(_, s) as e ->
-      if is_empty s then exit 1
-      else fatal_error (CErrors.print e) false
-    | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any)
-
+(** Main init routine *)
 let init_toplevel arglist =
+  (* Coq's init process, phase 1:
+     OCaml parameters, basic structures, and IO
+   *)
+  CProfile.init_profile ();
   init_gc ();
   Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+  let init_feeder = Feedback.add_feeder coqtop_init_feed in
   Lib.init();
-  (* Default Proofb Mode starts with an alternative default. *)
-  Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic";
-  begin
+
+  (* Coq's init process, phase 2:
+     Basic Coq environment, load-path, plugins.
+   *)
+  let res = begin
     try
-      let extras = parse_args arglist in
+      let opts,extras = parse_args arglist in
+      memory_stat := opts.memory_stat;
+
       (* If we have been spawned by the Spawn module, this has to be done
        * early since the master waits us to connect back *)
       Spawned.init_channels ();
-      Envars.set_coqlib CErrors.error;
-      if !print_where then (print_endline(Envars.coqlib ()); exit(exitcode ()));
-      if !print_config then (Usage.print_config (); exit (exitcode ()));
-      if !print_tags then (print_style_tags (); exit (exitcode ()));
-      if !filter_opts then (print_string (String.concat "\n" extras); exit 0);
-      init_load_path ();
-      Option.iter Mltop.load_ml_object_raw !toploop;
-      let extras = !toploop_init extras in
-      if not (List.is_empty extras) then begin
+      Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg));
+      if opts.print_where then (print_endline(Envars.coqlib ()); exit(exitcode opts));
+      if opts.print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode opts));
+      if opts.print_tags then (print_style_tags opts; exit (exitcode opts));
+      if opts.filter_opts then (print_string (String.concat "\n" extras); exit 0);
+      let top_lp = Coqinit.toplevel_init_load_path () in
+      List.iter Mltop.add_coq_path top_lp;
+      Option.iter Mltop.load_ml_object_raw opts.toploop;
+      let extras = !toploop_init opts extras in
+      if not (CList.is_empty extras) then begin
         prerr_endline ("Don't know what to do with "^String.concat " " extras);
         prerr_endline "See -help for the list of supported options";
         exit 1
       end;
-      if_verbose print_header ();
-      inputstate ();
+      Flags.if_verbose print_header ();
       Mltop.init_known_plugins ();
-      engage ();
-      if (not !batch_mode || List.is_empty !compile_list)
-         && Global.env_is_initial ()
-      then Option.iter Declaremods.start_library !toplevel_name;
-      init_library_roots ();
-      load_vernac_obj ();
-      require ();
-      Stm.init ();
-      load_rcfile();
-      load_vernacular ();
-      compile_files ();
-      schedule_vio_checking ();
-      schedule_vio_compilation ();
-      check_vio_tasks ();
-      outputstate ()
+      Global.set_engagement opts.impredicative_set;
+
+      (* Allow the user to load an arbitrary state here *)
+      inputstate opts;
+
+      (* This state will be shared by all the documents *)
+      Stm.init_core ();
+
+      (* Coq init process, phase 3: Stm initialization, backtracking state.
+
+         It is essential that the module system is in a consistent
+         state before we take the first snapshot. This was not
+         guaranteed in the past, but now is thanks to the STM API.
+
+         We split the codepath here depending whether coqtop is called
+         in interactive mode or not.  *)
+
+      (* The condition for starting the interactive mode is a bit
+         convoluted, we should really refactor batch/compilation_mode
+         more. *)
+      if (not opts.batch_mode
+          || CList.(is_empty opts.compile_list && is_empty opts.vio_files && is_empty opts.vio_tasks))
+      (* Interactive *)
+      then begin
+        let iload_path = build_load_path opts in
+        let require_libs = require_libs opts in
+        let stm_options = opts.stm_flags in
+        try
+          let open Vernac.State in
+          let doc, sid =
+            Stm.(new_doc
+                   { doc_type = Interactive opts.toplevel_name;
+                     iload_path; require_libs; stm_options;
+                   }) in
+          let state = { doc; sid; proof = None } in
+          Some (load_init_vernaculars opts ~state), opts
+        with any -> flush_all(); fatal_error_exn any
+      (* Non interactive: we perform a sequence of compilation steps *)
+      end else begin
+        try
+          compile_files opts;
+          (* Careful this will modify the load-path and state so after
+             this point some stuff may not be safe anymore. *)
+          do_vio opts;
+          (* Allow the user to output an arbitrary state *)
+          outputstate opts;
+          None, opts
+        with any -> flush_all(); fatal_error_exn any
+      end;
     with any ->
-      let any = CErrors.push any in
       flush_all();
-      let msg =
-        if !batch_mode then mt ()
-        else str "Error during initialization:" ++ fnl ()
-      in
-      let is_anomaly e = CErrors.is_anomaly e || not (CErrors.handled e) in
-      fatal_error (msg ++ Coqloop.print_toplevel_error any) (is_anomaly (fst any))
-  end;
-  if !batch_mode then begin
-    flush_all();
-    if !output_context then
-      Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ());
-    Profile.print_profile ();
-    exit 0
-  end
+      let extra = Some (str "Error during initialization: ") in
+      fatal_error_exn ?extra any
+  end in
+  Feedback.del_feeder init_feeder;
+  res
 
 let start () =
-  let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in
-  (* In batch mode, Coqtop has already exited at this point. In interactive one,
-     dump glob is nothing but garbage ...  *)
-  !toploop_run ();
-  exit 1
-
-(* [Coqtop.start] will be called by the code produced by coqmktop *)
+  match init_toplevel (List.tl (Array.to_list Sys.argv)) with
+  (* Batch mode *)
+  | Some state, opts when not opts.batch_mode ->
+    !toploop_run opts ~state;
+    exit 1
+  | _ , opts ->
+    flush_all();
+    if opts.output_context then begin
+      let sigma, env = Pfedit.get_current_context () in
+      Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ())
+    end;
+    CProfile.print_profile ();
+    exit 0
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index c9d1ba45..056279bb 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -1,9 +1,11 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 (** The Coq main module. The following function [start] will parse the
@@ -11,12 +13,10 @@
    state, load the files given on the command line, load the resource file,
    produce the output state if any, and finally will launch [Coqloop.loop]. *)
 
-val init_toplevel : string list -> unit
+val init_toplevel : string list -> Vernac.State.t option * Coqargs.coq_cmdopts
 
 val start : unit -> unit
 
-
 (* For other toploops *)
-val toploop_init : (string list -> string list) ref
-val toploop_run : (unit -> unit) ref
-
+val toploop_init : (Coqargs.coq_cmdopts -> string list -> string list) ref
+val toploop_run : (Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit) ref
diff --git a/toplevel/coqtop_byte_bin.ml b/toplevel/coqtop_byte_bin.ml
new file mode 100644
index 00000000..0b65cebb
--- /dev/null
+++ b/toplevel/coqtop_byte_bin.ml
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+let drop_setup () =
+  begin try
+    (* Enable rectypes in the toplevel if it has the directive #rectypes *)
+    begin match Hashtbl.find Toploop.directive_table "rectypes" with
+      | Toploop.Directive_none f -> f ()
+      | _ -> ()
+    end
+    with
+    | Not_found -> ()
+  end;
+  let ppf = Format.std_formatter in
+  Mltop.(set_top
+           { load_obj = (fun f -> if not (Topdirs.load_file ppf f)
+                          then CErrors.user_err Pp.(str ("Could not load plugin "^f))
+                        );
+             use_file = Topdirs.dir_use ppf;
+             add_dir  = Topdirs.dir_directory;
+             ml_loop  = (fun () -> Toploop.loop ppf);
+           })
+
+(* Main coqtop initialization *)
+let _ =
+  drop_setup ();
+  Coqtop.start()
diff --git a/toplevel/coqtop_opt_bin.ml b/toplevel/coqtop_opt_bin.ml
new file mode 100644
index 00000000..ea4c0ea5
--- /dev/null
+++ b/toplevel/coqtop_opt_bin.ml
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+let drop_setup () = Mltop.remove ()
+
+(* Main coqtop initialization *)
+let _ =
+  drop_setup ();
+  Coqtop.start()
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
deleted file mode 100644
index e24d5e74..00000000
--- a/toplevel/discharge.ml
+++ /dev/null
@@ -1,120 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open CErrors
-open Util
-open Term
-open Vars
-open Declarations
-open Cooking
-open Entries
-open Context.Rel.Declaration
-
-(********************************)
-(* Discharging mutual inductive *)
-
-let detype_param =
-  function
-  | LocalAssum (Name id, p) -> id, LocalAssumEntry p
-  | LocalDef (Name id, p,_) -> id, LocalDefEntry p
-  | _ -> anomaly (Pp.str "Unnamed inductive local variable")
-
-(* Replace
-
-     Var(y1)..Var(yq):C1..Cq |- Ij:Bj
-     Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti
-
-   by
-
-     |- Ij: (y1..yq:C1..Cq)Bj
-     I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)]
-*)
-
-let abstract_inductive hyps nparams inds =
-  let ntyp = List.length inds in
-  let nhyp = Context.Named.length hyps in
-  let args = Context.Named.to_instance (List.rev hyps) in
-  let args = Array.of_list args in
-  let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in
-  let inds' =
-    List.map
-      (function (tname,arity,template,cnames,lc) ->
-	let lc' = List.map (substl subs) lc in
-	let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
-	let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
-        (tname,arity',template,cnames,lc''))
-      	inds in
-  let nparams' = nparams + Array.length args in
-(* To be sure to be the same as before, should probably be moved to process_inductive *)
-  let params' = let (_,arity,_,_,_) = List.hd inds' in
-		let (params,_) = decompose_prod_n_assum nparams' arity in
-                List.map detype_param params
-  in
-  let ind'' =
-  List.map
-    (fun (a,arity,template,c,lc) ->
-      let _, short_arity = decompose_prod_n_assum nparams' arity in
-      let shortlc =
-	List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in
-      { mind_entry_typename = a;
-	mind_entry_arity = short_arity;
-	mind_entry_template = template;
-	mind_entry_consnames = c;
-	mind_entry_lc = shortlc })
-    inds'
-  in (params',ind'')
-
-let refresh_polymorphic_type_of_inductive (_,mip) =
-  match mip.mind_arity with
-  | RegularArity s -> s.mind_user_arity, false
-  | TemplateArity ar ->
-    let ctx = List.rev mip.mind_arity_ctxt in
-      mkArity (List.rev ctx, Type ar.template_level), true
-
-let process_inductive (sechyps,abs_ctx) modlist mib =
-  let nparams = mib.mind_nparams in
-  let subst, univs = 
-    if mib.mind_polymorphic then 
-      let inst = Univ.UContext.instance mib.mind_universes in
-      let cstrs = Univ.UContext.constraints mib.mind_universes in
-	inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs)
-    else Univ.Instance.empty, mib.mind_universes
-  in
-  let inds =
-    Array.map_to_list
-      (fun mip ->
-	let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in
-	let arity = expmod_constr modlist ty in
-	let arity = Vars.subst_instance_constr subst arity in
-	let lc = Array.map 
-	  (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c))
-	  mip.mind_user_lc 
-	in
-	  (mip.mind_typename,
-	   arity, template,
-	   Array.to_list mip.mind_consnames,
-	   Array.to_list lc))
-      mib.mind_packets in
-  let sechyps' = Context.Named.map (expmod_constr modlist) sechyps in
-  let (params',inds') = abstract_inductive sechyps' nparams inds in
-  let abs_ctx = Univ.instantiate_univ_context abs_ctx in
-  let univs = Univ.UContext.union abs_ctx univs in
-  let record = match mib.mind_record with
-    | Some (Some (id, _, _)) -> Some (Some id)
-    | Some None -> Some None
-    | None -> None
-  in
-  { mind_entry_record = record;
-    mind_entry_finite = mib.mind_finite;
-    mind_entry_params = params';
-    mind_entry_inds = inds';
-    mind_entry_polymorphic = mib.mind_polymorphic;
-    mind_entry_private = mib.mind_private;
-    mind_entry_universes = univs;
-  }
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
deleted file mode 100644
index 18d1b677..00000000
--- a/toplevel/discharge.mli
+++ /dev/null
@@ -1,14 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Declarations
-open Entries
-open Opaqueproof
-
-val process_inductive :
-  Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/doc.tex b/toplevel/doc.tex
deleted file mode 100644
index f2550fda..00000000
--- a/toplevel/doc.tex
+++ /dev/null
@@ -1,10 +0,0 @@
-
-\newpage
-\section*{The Coq toplevel}
-
-\ocwsection \label{toplevel}
-This chapter describes the highest modules of the \Coq\ system.
-They are organized as follows:
-
-\bigskip
-\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center}
diff --git a/toplevel/explainErr.ml b/toplevel/explainErr.ml
deleted file mode 100644
index 17897460..00000000
--- a/toplevel/explainErr.ml
+++ /dev/null
@@ -1,129 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Indtypes
-open Type_errors
-open Pretype_errors
-open Indrec
-
-let guill s = str "\"" ++ str s ++ str "\""
-
-(** Invariant : exceptions embedded in EvaluatedError satisfy
-    Errors.noncritical *)
-
-exception EvaluatedError of std_ppcmds * exn option
-
-(** Registration of generic errors
-    Nota: explain_exn does NOT end with a newline anymore!
-*)
-
-let explain_exn_default = function
-  (* Basic interaction exceptions *)
-  | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err))
-  | Sys_error msg -> hov 0 (str "System error: " ++ guill msg)
-  | Out_of_memory -> hov 0 (str "Out of memory.")
-  | Stack_overflow -> hov 0 (str "Stack overflow.")
-  | Timeout -> hov 0 (str "Timeout!")
-  | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.")
-  (* Exceptions with pre-evaluated error messages *)
-  | EvaluatedError (msg,None) -> msg
-  | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise
-  (* Otherwise, not handled here *)
-  | _ -> raise CErrors.Unhandled
-
-let _ = CErrors.register_handler explain_exn_default
-
-
-(** Pre-explain a vernac interpretation error *)
-
-let wrap_vernac_error with_header (exn, info) strm =
-  if with_header then
-    let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
-    let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
-    (e, info)
-  else
-    (EvaluatedError (strm, None), info)
-
-let process_vernac_interp_error with_header exn = match fst exn with
-  | Univ.UniverseInconsistency i ->
-    let msg =
-      if !Constrextern.print_universes then
-	str "." ++ spc() ++ 
-	  Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
-      else
-	mt() in
-    wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".")
-  | TypeError(ctx,te) ->
-      wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te)
-  | PretypeError(ctx,sigma,te) ->
-      wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te)
-  | Typeclasses_errors.TypeClassError(env, te) ->
-      wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te)
-  | InductiveError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_inductive_error e)
-  | Modops.ModuleTypingError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_module_error e)
-  | Modintern.ModuleInternalizationError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e)
-  | RecursionSchemeError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e)
-  | Cases.PatternMatchingError (env,sigma,e) ->
-      wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e)
-  | Tacred.ReductionTacticError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e)
-  | Logic.RefinerError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_refiner_error e)
-  | Nametab.GlobalizationError q ->
-      wrap_vernac_error with_header exn
-        (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
-	 spc () ++ str "was not found" ++
-	 spc () ++ str "in the current" ++ spc () ++ str "environment.")
-  | Refiner.FailError (i,s) ->
-      let s = Lazy.force s in
-      wrap_vernac_error with_header exn
-	(str "Tactic failure" ++
-         (if Pp.is_empty s then s else str ": " ++ s) ++
-         if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").")
-  | AlreadyDeclared msg ->
-      wrap_vernac_error with_header exn (msg ++ str ".")
-  | _ ->
-      exn
-
-let rec strip_wrapping_exceptions = function
-  | Logic_monad.TacticFailure e ->
-    strip_wrapping_exceptions e
-  | exc -> exc
-
-let additional_error_info = ref []
-
-let register_additional_error_info f =
-  additional_error_info := f :: !additional_error_info
-
-let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) =
-  let exc = strip_wrapping_exceptions exc in
-  let e = process_vernac_interp_error with_header (exc, info) in
-  let () =
-    if not allow_uncaught && not (CErrors.handled (fst e)) then
-      let (e, info) = e in
-      let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in
-      let err = CErrors.make_anomaly msg in
-      Util.iraise (err, info)
-  in
-  let e' =
-    try Some (CList.find_map (fun f -> f e) !additional_error_info)
-    with _ -> None
-  in
-  match e' with
-  | None -> e
-  | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc)
-  | Some (Some msg, loc) ->
-    (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc)
diff --git a/toplevel/explainErr.mli b/toplevel/explainErr.mli
deleted file mode 100644
index a67c887a..00000000
--- a/toplevel/explainErr.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Toplevel Exception *)
-exception EvaluatedError of Pp.std_ppcmds * exn option
-
-(** Pre-explain a vernac interpretation error *)
-
-val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn
-
-(** General explain function. Should not be used directly now,
-    see instead function [Errors.print] and variants *)
-
-val explain_exn_default : exn -> Pp.std_ppcmds
-
-val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
deleted file mode 100644
index f98505c3..00000000
--- a/toplevel/himsg.ml
+++ /dev/null
@@ -1,1267 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Namegen
-open Term
-open Termops
-open Indtypes
-open Environ
-open Pretype_errors
-open Type_errors
-open Typeclasses_errors
-open Indrec
-open Cases
-open Logic
-open Printer
-open Evd
-open Context.Rel.Declaration
-
-(* This simplifies the typing context of Cases clauses *)
-(* hope it does not disturb other typing contexts *)
-let contract env lc =
-  let l = ref [] in
-  let contract_context decl env =
-    match decl with
-      | LocalDef (_,c',_) when isRel c' ->
-          l := (Vars.substl !l c') :: !l;
-          env
-      | _ ->
-          let t' = Vars.substl !l (get_type decl) in
-          let c' = Option.map (Vars.substl !l) (get_value decl) in
-          let na' = named_hd env t' (get_name decl) in
-          l := (mkRel 1) :: List.map (Vars.lift 1) !l;
-          match c' with
-          | None -> push_rel (LocalAssum (na',t')) env
-          | Some c' -> push_rel (LocalDef (na',c',t')) env
-  in
-  let env = process_rel_context contract_context env in
-  (env, List.map (Vars.substl !l) lc)
-
-let contract2 env a b = match contract env [a;b] with
-  | env, [a;b] -> env,a,b | _ -> assert false
-
-let contract3 env a b c = match contract env [a;b;c] with
-  | env, [a;b;c] -> env,a,b,c | _ -> assert false
-
-let contract4 env a b c d = match contract env [a;b;c;d] with
-  | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false
-
-let contract1_vect env a v =
-  match contract env (a :: Array.to_list v) with
-  | env, a::l -> env,a,Array.of_list l
-  | _ -> assert false
-
-let rec contract3' env a b c = function
-  | OccurCheck (evk,d) -> let x,d = contract4 env a b c d in x,OccurCheck(evk,d)
-  | NotClean ((evk,args),env',d) ->
-      let env',d,args = contract1_vect env' d args in
-      contract3 env a b c,NotClean((evk,args),env',d)
-  | ConversionFailed (env',t1,t2) ->
-      let (env',t1,t2) = contract2 env' t1 t2 in
-      contract3 env a b c, ConversionFailed (env',t1,t2)
-  | NotSameArgSize | NotSameHead | NoCanonicalStructure
-  | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities
-  | UnifUnivInconsistency _ as x -> contract3 env a b c, x
-  | CannotSolveConstraint ((pb,env',t,u),x) ->
-      let env',t,u = contract2 env' t u in
-      let y,x = contract3' env a b c x in
-      y,CannotSolveConstraint ((pb,env',t,u),x)
-
-(** Ad-hoc reductions *)
-
-let j_nf_betaiotaevar sigma j =
-  { uj_val = Evarutil.nf_evar sigma j.uj_val;
-    uj_type = Reductionops.nf_betaiota sigma j.uj_type }
-
-let jv_nf_betaiotaevar sigma jl =
-  Array.map (j_nf_betaiotaevar sigma) jl
-
-(** Printers *)
-
-let pr_lconstr c = quote (pr_lconstr c)
-let pr_lconstr_env e s c = quote (pr_lconstr_env e s c)
-let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t)
-
-(** A canonisation procedure for constr such that comparing there
-    externalisation catches more equalities *)
-let canonize_constr c =
-  (* replaces all the names in binders by [dn] ("default name"),
-     ensures that [alpha]-equivalent terms will have the same
-     externalisation. *)
-  let dn = Name.Anonymous in
-  let rec canonize_binders c =
-    match Term.kind_of_term c with
-    | Prod (_,t,b) -> mkProd(dn,t,b)
-    | Lambda (_,t,b) -> mkLambda(dn,t,b)
-    | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b)
-    | _ -> Term.map_constr canonize_binders c
-  in
-  canonize_binders c
-
-(** Tries to realize when the two terms, albeit different are printed the same. *)
-let display_eq ~flags env sigma t1 t2 =
-  (* terms are canonized, then their externalisation is compared syntactically *)
-  let open Constrextern in
-  let t1 = canonize_constr t1 in
-  let t2 = canonize_constr t2 in
-  let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in
-  let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in
-  Constrexpr_ops.constr_expr_eq ct1 ct2
-
-(** This function adds some explicit printing flags if the two arguments are
-    printed alike. *)
-let rec pr_explicit_aux env sigma t1 t2 = function
-| [] ->
-  (** no specified flags: default. *)
-  (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2))
-| flags :: rem ->
-  let equal = display_eq ~flags env sigma t1 t2 in
-  if equal then
-    (** The two terms are the same from the user point of view *)
-    pr_explicit_aux env sigma t1 t2 rem
-  else
-    let open Constrextern in
-    let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) ()
-    in
-    let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) ()
-    in
-    quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2)
-
-let explicit_flags =
-  let open Constrextern in
-  [ []; (** First, try with the current flags *)
-    [print_implicits]; (** Then with implicit *)
-    [print_universes]; (** Then with universes *)
-    [print_universes; print_implicits]; (** With universes AND implicits *)
-    [print_implicits; print_coercions; print_no_symbol]; (** Then more! *)
-    [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ]
-
-let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags
-
-let pr_db env i =
-  try
-    match lookup_rel i env |> get_name with
-      | Name id -> pr_id id
-      | Anonymous -> str "<>"
-  with Not_found -> str "UNBOUND_REL_" ++ int i
-
-let explain_unbound_rel env sigma n =
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  str "Unbound reference: " ++ pe ++
-  str "The reference " ++ int n ++ str " is free."
-
-let explain_unbound_var env v =
-  let var = pr_id v in
-  str "No such section variable or assumption: " ++ var ++ str "."
-
-let explain_not_type env sigma j =
-  let j = Evarutil.j_nf_evar sigma j in
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  let pc,pt = pr_ljudge_env env sigma j in
-  pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++
-  str "has type" ++ spc () ++ pt ++ spc () ++
-  str "which should be Set, Prop or Type."
-
-let explain_bad_assumption env sigma j =
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  let pc,pt = pr_ljudge_env env sigma j in
-  pe ++ str "Cannot declare a variable or hypothesis over the term" ++
-  brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++
-  str "because this term is not a type."
-
-let explain_reference_variables id c =
-  (* c is intended to be a global reference *)
-  let pc = pr_global (Globnames.global_of_constr c) in
-  pc ++ strbrk " depends on the variable " ++ pr_id id ++
-  strbrk " which is not declared in the context."
-
-let rec pr_disjunction pr = function
-  | [a] -> pr  a
-  | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b
-  | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l
-  | [] -> assert false
-
-let pr_puniverses f env (c,u) = 
-  f env c ++ 
-  (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then
-    str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
-  else mt())
-
-let explain_elim_arity env sigma ind sorts c pj okinds =
-  let env = make_all_name_different env in
-  let pi = pr_inductive env (fst ind) in
-  let pc = pr_lconstr_env env sigma c in
-  let msg = match okinds with
-  | Some(kp,ki,explanation) ->
-      let pki = pr_sort_family ki in
-      let pkp = pr_sort_family kp in
-      let explanation =	match explanation with
-	| NonInformativeToInformative ->
-          "proofs can be eliminated only to build proofs"
-	| StrongEliminationOnNonSmallType ->
-          "strong elimination on non-small inductive types leads to paradoxes"
-	| WrongArity ->
-	  "wrong arity" in
-      let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
-      let ppt = pr_lconstr_env env sigma ((strip_prod_assum pj.uj_type)) in
-      hov 0
-	(str "the return type has sort" ++ spc () ++ ppt ++ spc () ++
-	 str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++
-      fnl () ++
-      hov 0
-	(str "Elimination of an inductive object of sort " ++
-	 pki ++ brk(1,0) ++
-         str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++
-         str "because" ++ spc () ++ str explanation ++ str ".")
-  | None ->
-      str "ill-formed elimination predicate."
-  in
-  hov 0 (
-    str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++
-    str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++
-  fnl () ++ msg
-
-let explain_case_not_inductive env sigma cj =
-  let cj = Evarutil.j_nf_evar sigma cj in
-  let env = make_all_name_different env in
-  let pc = pr_lconstr_env env sigma cj.uj_val in
-  let pct = pr_lconstr_env env sigma cj.uj_type in
-    match kind_of_term cj.uj_type with
-      | Evar _ ->
-	  str "Cannot infer a type for this expression."
-      | _ ->
-	  str "The term" ++ brk(1,1) ++ pc ++ spc () ++
-	  str "has type" ++ brk(1,1) ++ pct ++ spc () ++
-	  str "which is not a (co-)inductive type."
-
-let explain_number_branches env sigma cj expn =
-  let cj = Evarutil.j_nf_evar sigma cj in
-  let env = make_all_name_different env in
-  let pc = pr_lconstr_env env sigma cj.uj_val in
-  let pct = pr_lconstr_env env sigma cj.uj_type in
-  str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++
-  str "of type" ++ brk(1,1) ++ pct ++ spc () ++
-  str "expects " ++  int expn ++ str " branches."
-
-let explain_ill_formed_branch env sigma c ci actty expty =
-  let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in
-  let c = Evarutil.nf_evar sigma c in
-  let env = make_all_name_different env in
-  let pc = pr_lconstr_env env sigma c in
-  let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in
-  strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++
-  spc () ++ strbrk "the branch for constructor" ++ spc () ++
-  quote (pr_puniverses pr_constructor env ci) ++
-  spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++
-  str "which should be" ++ brk(1,1) ++ pe ++ str "."
-
-let explain_generalization env sigma (name,var) j =
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  let pv = pr_ltype_env env sigma var in
-  let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in
-  pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
-  str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++
-  str "it has type" ++ spc () ++ pt ++
-  spc () ++ str "which should be Set, Prop or Type."
-
-let explain_unification_error env sigma p1 p2 = function
-  | None -> mt()
-  | Some e ->
-     let rec aux p1 p2 = function
-     | OccurCheck (evk,rhs) ->
-        let rhs = Evarutil.nf_evar sigma rhs in
-        [str "cannot define " ++ quote (pr_existential_key sigma evk) ++
-	strbrk " with term " ++ pr_lconstr_env env sigma rhs ++
-        strbrk " that would depend on itself"]
-     | NotClean ((evk,args),env,c) ->
-        let c = Evarutil.nf_evar sigma c in
-        let args = Array.map (Evarutil.nf_evar sigma) args in
-        [str "cannot instantiate " ++ quote (pr_existential_key sigma evk)
-        ++ strbrk " because " ++ pr_lconstr_env env sigma c ++
-	strbrk " is not in its scope" ++
-        (if Array.is_empty args then mt() else
-         strbrk ": available arguments are " ++
-         pr_sequence (pr_lconstr_env env sigma) (List.rev (Array.to_list args)))]
-     | NotSameArgSize | NotSameHead | NoCanonicalStructure ->
-        (* Error speaks from itself *) []
-     | ConversionFailed (env,t1,t2) ->
-        if Term.eq_constr t1 p1 && Term.eq_constr t2 p2 then [] else
-        let env = make_all_name_different env in
-        let t1 = Evarutil.nf_evar sigma t1 in
-        let t2 = Evarutil.nf_evar sigma t2 in
-        if not (Term.eq_constr t1 p1) || not (Term.eq_constr t2 p2) then
-          let t1, t2 = pr_explicit env sigma t1 t2 in
-          [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2]
-        else []
-     | MetaOccurInBody evk ->
-        [str "instance for " ++ quote (pr_existential_key sigma evk) ++
-	strbrk " refers to a metavariable - please report your example" ++
-        strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."]
-     | InstanceNotSameType (evk,env,t,u) ->
-        let t, u = pr_explicit env sigma t u in
-        [str "unable to find a well-typed instantiation for " ++
-        quote (pr_existential_key sigma evk) ++
-        strbrk ": cannot ensure that " ++
-        t ++ strbrk " is a subtype of " ++ u]
-     | UnifUnivInconsistency p ->
-        if !Constrextern.print_universes then
-	  [str "universe inconsistency: " ++
-          Univ.explain_universe_inconsistency Universes.pr_with_global_universes p]
-	else
-          [str "universe inconsistency"]
-     | CannotSolveConstraint ((pb,env,t,u),e) ->
-        let t = Evarutil.nf_evar sigma t in
-        let u = Evarutil.nf_evar sigma u in
-        let env = make_all_name_different env in
-        (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++
-        str " == " ++ pr_lconstr_env env sigma u)
-        :: aux t u e
-     | ProblemBeyondCapabilities ->
-        []
-     in
-     match aux p1 p2 e with
-     | [] -> mt ()
-     | l -> spc () ++ str "(" ++
-            prlist_with_sep pr_semicolon (fun x -> x) l ++ str ")"
-
-let explain_actual_type env sigma j t reason =
-  let env = make_all_name_different env in
-  let j = j_nf_betaiotaevar sigma j in
-  let t = Reductionops.nf_betaiota sigma t in
-  (** Actually print *)
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  let pc = pr_lconstr_env env sigma (Environ.j_val j) in
-  let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in
-  let ppreason = explain_unification_error env sigma j.uj_type t reason in
-  pe ++
-  hov 0 (
-  str "The term" ++ brk(1,1) ++ pc ++ spc () ++
-  str "has type" ++ brk(1,1) ++ pct ++ spc () ++
-  str "while it is expected to have type" ++ brk(1,1) ++ pt ++
-  ppreason ++ str ".")
-
-let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
-  let randl = jv_nf_betaiotaevar sigma randl in
-  let exptyp = Evarutil.nf_evar sigma exptyp in
-  let actualtyp = Reductionops.nf_betaiota sigma actualtyp in
-  let rator = Evarutil.j_nf_evar sigma rator in
-  let env = make_all_name_different env in
-  let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in
-  let nargs = Array.length randl in
-(*  let pe = pr_ne_context_of (str "in environment") env sigma in*)
-  let pr,prt = pr_ljudge_env env sigma rator in
-  let term_string1 = str (String.plural nargs "term") in
-  let term_string2 =
-    if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term"
-  in
-  let appl = prvect_with_sep fnl
-	       (fun c ->
-		  let pc,pct = pr_ljudge_env env sigma c in
-		  hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
-  in
-  str "Illegal application: " ++ (* pe ++ *) fnl () ++
-  str "The term" ++ brk(1,1) ++ pr ++ spc () ++
-  str "of type" ++ brk(1,1) ++ prt ++ spc () ++
-  str "cannot be applied to the " ++ term_string1 ++ fnl () ++
-  str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++
-  brk(1,1) ++ actualtyp ++ spc () ++
-  str "which should be coercible to" ++ brk(1,1) ++
-  exptyp ++ str "."
-
-let explain_cant_apply_not_functional env sigma rator randl =
-  let randl = Evarutil.jv_nf_evar sigma randl in
-  let rator = Evarutil.j_nf_evar sigma rator in
-  let env = make_all_name_different env in
-  let nargs = Array.length randl in
-(*  let pe = pr_ne_context_of (str "in environment") env sigma in*)
-  let pr = pr_lconstr_env env sigma rator.uj_val in
-  let prt = pr_lconstr_env env sigma rator.uj_type in
-  let appl = prvect_with_sep fnl
-	       (fun c ->
-		  let pc = pr_lconstr_env env sigma c.uj_val in
-		  let pct = pr_lconstr_env env sigma c.uj_type in
-		  hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
-  in
-  str "Illegal application (Non-functional construction): " ++
-  (* pe ++ *) fnl () ++
-  str "The expression" ++ brk(1,1) ++ pr ++ spc () ++
-  str "of type" ++ brk(1,1) ++ prt ++ spc () ++
-  str "cannot be applied to the " ++ str (String.plural nargs "term") ++
-  fnl () ++ str " " ++ v 0 appl
-
-let explain_unexpected_type env sigma actual_type expected_type =
-  let actual_type = Evarutil.nf_evar sigma actual_type in
-  let expected_type = Evarutil.nf_evar sigma expected_type in
-  let pract, prexp = pr_explicit env sigma actual_type expected_type in
-  str "Found type" ++ spc () ++ pract ++ spc () ++
-  str "where" ++ spc () ++ prexp ++ str " was expected."
-
-let explain_not_product env sigma c =
-  let c = Evarutil.nf_evar sigma c in
-  let pr = pr_lconstr_env env sigma c in
-  str "The type of this term is a product" ++ spc () ++
-  str "while it is expected to be" ++
-  (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
-
-(* TODO: use the names *)
-(* (co)fixpoints *)
-let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
-  let prt_name i =
-    match names.(i) with
-        Name id -> str "Recursive definition of " ++ pr_id id
-      | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in
-
-  let st = match err with
-
-  (* Fixpoint guard errors *)
-  | NotEnoughAbstractionInFixBody ->
-      str "Not enough abstractions in the definition"
-  | RecursionNotOnInductiveType c ->
-      str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++
-      spc () ++ str "which should be an inductive type"
-  | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) ->
-      let arg_env = make_all_name_different arg_env in
-      let called =
-        match names.(j) with
-            Name id -> pr_id id
-          | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
-      let pr_db x = quote (pr_db env x) in
-      let vars =
-        match (lt,le) with
-            ([],[]) -> assert false
-          | ([],[x]) -> str "a subterm of " ++ pr_db x
-          | ([],_) -> str "a subterm of the following variables: " ++
-              pr_sequence pr_db le
-          | ([x],_) -> pr_db x
-          | _ ->
-              str "one of the following variables: " ++
-              pr_sequence pr_db lt in
-      str "Recursive call to " ++ called ++ spc () ++
-      strbrk "has principal argument equal to" ++ spc () ++
-      pr_lconstr_env arg_env sigma arg ++ strbrk " instead of " ++ vars
-
-  | NotEnoughArgumentsForFixCall j ->
-      let called =
-        match names.(j) with
-            Name id -> pr_id id
-          | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
-     str "Recursive call to " ++ called ++ str " has not enough arguments"
-
-  (* CoFixpoint guard errors *)
-  | CodomainNotInductiveType c ->
-      str "The codomain is" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++
-      str "which should be a coinductive type"
-  | NestedRecursiveOccurrences ->
-      str "Nested recursive occurrences"
-  | UnguardedRecursiveCall c ->
-      str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env sigma c
-  | RecCallInTypeOfAbstraction c ->
-      str "Recursive call forbidden in the domain of an abstraction:" ++
-      spc () ++ pr_lconstr_env env sigma c
-  | RecCallInNonRecArgOfConstructor c ->
-      str "Recursive call on a non-recursive argument of constructor" ++
-      spc () ++ pr_lconstr_env env sigma c
-  | RecCallInTypeOfDef c ->
-      str "Recursive call forbidden in the type of a recursive definition" ++
-      spc () ++ pr_lconstr_env env sigma c
-  | RecCallInCaseFun c ->
-      str "Invalid recursive call in a branch of" ++
-      spc () ++ pr_lconstr_env env sigma c
-  | RecCallInCaseArg c ->
-      str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++
-      pr_lconstr_env env sigma c
-  | RecCallInCasePred c ->
-      str "Invalid recursive call in the \"return\" clause of \"match\" in" ++
-      spc () ++ pr_lconstr_env env sigma c
-  | NotGuardedForm c ->
-      str "Sub-expression " ++ pr_lconstr_env env sigma c ++
-      strbrk " not in guarded form (should be a constructor," ++
-      strbrk " an abstraction, a match, a cofix or a recursive call)"
-  | ReturnPredicateNotCoInductive c ->
-     str "The return clause of the following pattern matching should be" ++
-     strbrk " a coinductive type:" ++
-     spc () ++ pr_lconstr_env env sigma c
-  in
-  prt_name i ++ str " is ill-formed." ++ fnl () ++
-  pr_ne_context_of (str "In environment") env sigma ++
-  st ++ str "." ++ fnl () ++
-  (try (* May fail with unresolved globals. *)
-      let fixenv = make_all_name_different fixenv in
-      let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in
-	str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
-    with e when CErrors.noncritical e -> mt ())
-
-let explain_ill_typed_rec_body env sigma i names vdefj vargs =
-  let vdefj = Evarutil.jv_nf_evar sigma vdefj in
-  let vargs = Array.map (Evarutil.nf_evar sigma) vargs in
-  let env = make_all_name_different env in
-  let pvd = pr_lconstr_env env sigma vdefj.(i).uj_val in
-  let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in
-  str "The " ++
-  (match vdefj with [|_|] -> mt () | _ -> pr_nth (i+1) ++ spc ()) ++
-  str "recursive definition" ++ spc () ++ pvd ++ spc () ++
-  str "has type" ++ spc () ++ pvdt ++ spc () ++
-  str "while it should be" ++ spc () ++ pv ++ str "."
-
-let explain_cant_find_case_type env sigma c =
-  let c = Evarutil.nf_evar sigma c in
-  let env = make_all_name_different env in
-  let pe = pr_lconstr_env env sigma c in
-  str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++
-    pe ++ str "."
-
-let explain_occur_check env sigma ev rhs =
-  let rhs = Evarutil.nf_evar sigma rhs in
-  let env = make_all_name_different env in
-  let pt = pr_lconstr_env env sigma rhs in
-  str "Cannot define " ++ pr_existential_key sigma ev ++ str " with term" ++
-  brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself."
-
-let pr_trailing_ne_context_of env sigma =
-  if List.is_empty (Environ.rel_context env) &&
-    List.is_empty (Environ.named_context env)
-  then str "."
-  else (str " in environment:"++ pr_context_unlimited env sigma)
-
-let rec explain_evar_kind env sigma evk ty = function
-  | Evar_kinds.QuestionMark _ ->
-      strbrk "this placeholder of type " ++ ty
-  | Evar_kinds.CasesType false ->
-      strbrk "the type of this pattern-matching problem"
-  | Evar_kinds.CasesType true ->
-      strbrk "a subterm of type " ++ ty ++
-      strbrk " in the type of this pattern-matching problem"
-  | Evar_kinds.BinderType (Name id) ->
-      strbrk "the type of " ++ Nameops.pr_id id
-  | Evar_kinds.BinderType Anonymous ->
-      strbrk "the type of this anonymous binder"
-  | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
-      let id = Option.get ido in
-      strbrk "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++
-      spc () ++ Nametab.pr_global_env Id.Set.empty c ++
-      strbrk " whose type is " ++ ty
-  | Evar_kinds.InternalHole -> strbrk "an internal placeholder of type " ++ ty
-  | Evar_kinds.TomatchTypeParameter (tyi,n) ->
-      strbrk "the " ++ pr_nth n ++
-      strbrk " argument of the inductive type (" ++ pr_inductive env tyi ++
-      strbrk ") of this term"
-  | Evar_kinds.GoalEvar ->
-      strbrk "an existential variable of type " ++ ty
-  | Evar_kinds.ImpossibleCase ->
-      strbrk "the type of an impossible pattern-matching clause"
-  | Evar_kinds.MatchingVar _ ->
-      assert false
-  | Evar_kinds.VarInstance id ->
-      strbrk "an instance of type " ++ ty ++
-      str " for the variable " ++ pr_id id
-  | Evar_kinds.SubEvar evk' ->
-      let evi = Evd.find sigma evk' in
-      let pc = match evi.evar_body with
-      | Evar_defined c -> pr_lconstr_env env sigma (Evarutil.nf_evar sigma c)
-      | Evar_empty -> assert false in
-      let ty' = Evarutil.nf_evar sigma evi.evar_concl in
-      pr_existential_key sigma evk ++ str " of type " ++ ty ++
-      str " in the partial instance " ++ pc ++
-      str " found for " ++ explain_evar_kind env sigma evk'
-      (pr_lconstr_env env sigma ty') (snd evi.evar_source)
-
-let explain_typeclass_resolution env sigma evi k =
-  match Typeclasses.class_of_constr evi.evar_concl with
-  | Some _ ->
-    let env = Evd.evar_filtered_env evi in
-      fnl () ++ str "Could not find an instance for " ++
-      pr_lconstr_env env sigma evi.evar_concl ++
-      pr_trailing_ne_context_of env sigma
-  | _ -> mt()
-
-let explain_placeholder_kind env sigma c e =
-  match e with
-  | Some (SeveralInstancesFound n) ->
-      strbrk " (several distinct possible type class instances found)"
-  | None ->
-      match Typeclasses.class_of_constr c with
-      | Some _ -> strbrk " (no type class instance found)"
-      | _ -> mt ()
-
-let explain_unsolvable_implicit env sigma evk explain =
-  let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in
-  let env = Evd.evar_filtered_env evi in
-  let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in
-  let pe = pr_trailing_ne_context_of env sigma in
-  strbrk "Cannot infer " ++
-  explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++
-  explain_placeholder_kind env sigma evi.evar_concl explain ++ pe
-
-let explain_var_not_found env id =
-  str "The variable" ++ spc () ++ pr_id id ++
-  spc () ++ str "was not found" ++
-  spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "."
-
-let explain_wrong_case_info env (ind,u) ci =
-  let pi = pr_inductive (Global.env()) ind in
-  if eq_ind ci.ci_ind ind then
-    str "Pattern-matching expression on an object of inductive type" ++
-    spc () ++ pi ++ spc () ++ str "has invalid information."
-  else
-    let pc = pr_inductive (Global.env()) ci.ci_ind in
-    str "A term of inductive type" ++ spc () ++ pi ++ spc () ++
-    str "was given to a pattern-matching expression on the inductive type" ++
-    spc () ++ pc ++ str "."
-
-let explain_cannot_unify env sigma m n e =
-  let env = make_all_name_different env in
-  let m = Evarutil.nf_evar sigma m in
-  let n = Evarutil.nf_evar sigma n in
-  let pm, pn = pr_explicit env sigma m n in
-  let ppreason = explain_unification_error env sigma m n e in
-  let pe = pr_ne_context_of (str "In environment") env sigma in
-  pe ++ str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
-  str "with" ++ brk(1,1) ++ pn ++ ppreason ++ str "."
-
-let explain_cannot_unify_local env sigma m n subn =
-  let pm = pr_lconstr_env env sigma m in
-  let pn = pr_lconstr_env env sigma n in
-  let psubn = pr_lconstr_env env sigma subn in
-    str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
-      str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++
-      psubn ++ str " contains local variables."
-
-let explain_refiner_cannot_generalize env sigma ty =
-  str "Cannot find a well-typed generalisation of the goal with type: " ++
-  pr_lconstr_env env sigma ty ++ str "."
-
-let explain_no_occurrence_found env sigma c id =
-  str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++
-  str " in " ++
-    (match id with
-      | Some id -> pr_id id
-      | None -> str"the current goal") ++ str "."
-
-let explain_cannot_unify_binding_type env sigma m n =
-  let pm = pr_lconstr_env env sigma m in
-  let pn = pr_lconstr_env env sigma n in
-  str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++
-  str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "."
-
-let explain_cannot_find_well_typed_abstraction env sigma p l e =
-  str "Abstracting over the " ++
-  str (String.plural (List.length l) "term") ++ spc () ++
-  hov 0 (pr_enum (pr_lconstr_env env sigma) l) ++ spc () ++
-  str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++
-  spc () ++ str "which is ill-typed." ++
-  (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e)
-
-let explain_wrong_abstraction_type env sigma na abs expected result =
-  let ppname = match na with Name id -> pr_id id ++ spc () | _ -> mt () in
-  str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++
-  pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++
-  pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++
-  pr_lconstr_env env sigma result ++ str "."
-
-let explain_abstraction_over_meta _ m n =
-  strbrk "Too complex unification problem: cannot find a solution for both " ++
-  pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
-
-let explain_non_linear_unification env sigma m t =
-  strbrk "Cannot unambiguously instantiate " ++
-  pr_name m ++ str ":" ++
-  strbrk " which would require to abstract twice on " ++
-  pr_lconstr_env env sigma t ++ str "."
-
-let explain_unsatisfied_constraints env sigma cst =
-  strbrk "Unsatisfied constraints: " ++ 
-    Univ.pr_constraints (Evd.pr_evd_level sigma) cst ++ 
-    spc () ++ str "(maybe a bugged tactic)."
-
-let explain_type_error env sigma err =
-  let env = make_all_name_different env in
-  match err with
-  | UnboundRel n ->
-      explain_unbound_rel env sigma n
-  | UnboundVar v ->
-      explain_unbound_var env v
-  | NotAType j ->
-      explain_not_type env sigma j
-  | BadAssumption c ->
-      explain_bad_assumption env sigma c
-  | ReferenceVariables (id,c) ->
-      explain_reference_variables id c
-  | ElimArity (ind, aritylst, c, pj, okinds) ->
-      explain_elim_arity env sigma ind aritylst c pj okinds
-  | CaseNotInductive cj ->
-      explain_case_not_inductive env sigma cj
-  | NumberBranches (cj, n) ->
-      explain_number_branches env sigma cj n
-  | IllFormedBranch (c, i, actty, expty) ->
-      explain_ill_formed_branch env sigma c i actty expty
-  | Generalization (nvar, c) ->
-      explain_generalization env sigma nvar c
-  | ActualType (j, pt) ->
-      explain_actual_type env sigma j pt None
-  | CantApplyBadType (t, rator, randl) ->
-      explain_cant_apply_bad_type env sigma t rator randl
-  | CantApplyNonFunctional (rator, randl) ->
-      explain_cant_apply_not_functional env sigma rator randl
-  | IllFormedRecBody (err, lna, i, fixenv, vdefj) ->
-      explain_ill_formed_rec_body env sigma err lna i fixenv vdefj
-  | IllTypedRecBody (i, lna, vdefj, vargs) ->
-     explain_ill_typed_rec_body env sigma i lna vdefj vargs
-  | WrongCaseInfo (ind,ci) ->
-      explain_wrong_case_info env ind ci
-  | UnsatisfiedConstraints cst ->
-      explain_unsatisfied_constraints env sigma cst
-
-let pr_position (cl,pos) =
-  let clpos = match cl with
-    | None -> str " of the goal"
-    | Some (id,Locus.InHyp) -> str " of hypothesis " ++ pr_id id
-    | Some (id,Locus.InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id
-    | Some (id,Locus.InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in
-  int pos ++ clpos
-
-let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1),t1) e =
-  if nested then
-    str "Found nested occurrences of the pattern at positions " ++
-    int pos1 ++ strbrk " and " ++ pr_position (cl2,pos2) ++ str "."
-  else
-    let ppreason = match e with None -> mt() | Some (c1,c2,e) -> explain_unification_error env sigma c1 c2 (Some e) in
-    str "Found incompatible occurrences of the pattern" ++ str ":" ++
-    spc () ++ str "Matched term " ++ pr_lconstr_env env sigma t2 ++
-    strbrk " at position " ++ pr_position (cl2,pos2) ++
-    strbrk " is not compatible with matched term " ++
-    pr_lconstr_env env sigma t1 ++ strbrk " at position " ++
-    pr_position (cl1,pos1) ++ ppreason ++ str "."
-
-let pr_constraints printenv env sigma evars cstrs =
-  let (ev, evi) = Evar.Map.choose evars in
-    if Evar.Map.for_all (fun ev' evi' ->
-      eq_named_context_val evi.evar_hyps evi'.evar_hyps) evars
-    then
-      let l = Evar.Map.bindings evars in
-      let env' = reset_with_named_context evi.evar_hyps env in
-      let pe =
-        if printenv then
-          pr_ne_context_of (str "In environment:") env' sigma
-        else mt ()
-      in
-      let evs =
-        prlist
-        (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++
-            str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l
-      in
-      h 0 (pe ++ evs ++ pr_evar_constraints cstrs)
-    else
-      let filter evk _ = Evar.Map.mem evk evars in
-      pr_evar_map_filter ~with_univs:false filter sigma
-
-let explain_unsatisfiable_constraints env sigma constr comp =
-  let (_, constraints) = Evd.extract_all_conv_pbs sigma in
-  let undef = Evd.undefined_map (Evarutil.nf_evar_map_undefined sigma) in
-  (** Only keep evars that are subject to resolution and members of the given
-     component. *)
-  let is_kept evk evi = match comp with
-  | None -> Typeclasses.is_resolvable evi
-  | Some comp -> Typeclasses.is_resolvable evi && Evar.Set.mem evk comp
-  in
-  let undef = 
-    let m = Evar.Map.filter is_kept undef in
-      if Evar.Map.is_empty m then undef
-      else m
-  in
-  match constr with
-  | None ->
-    str "Unable to satisfy the following constraints:" ++ fnl () ++
-    pr_constraints true env sigma undef constraints
-  | Some (ev, k) ->
-    let cstr =
-      let remaining = Evar.Map.remove ev undef in
-      if not (Evar.Map.is_empty remaining) then
-        str "With the following constraints:" ++ fnl () ++
-          pr_constraints false env sigma remaining constraints
-      else mt ()
-    in
-    let info = Evar.Map.find ev undef in
-    explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr
-
-let explain_pretype_error env sigma err =
-  let env = Evardefine.env_nf_betaiotaevar sigma env in
-  let env = make_all_name_different env in
-  match err with
-  | CantFindCaseType c -> explain_cant_find_case_type env sigma c
-  | ActualTypeNotCoercible (j,t,e) ->
-    let {uj_val = c; uj_type = actty} = j in
-    let (env, c, actty, expty), e = contract3' env c actty t e in
-    let j = {uj_val = c; uj_type = actty} in
-    explain_actual_type env sigma j expty (Some e)
-  | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs
-  | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp
-  | VarNotFound id -> explain_var_not_found env id
-  | UnexpectedType (actual,expect) ->
-    let env, actual, expect = contract2 env actual expect in
-    explain_unexpected_type env sigma actual expect
-  | NotProduct c -> explain_not_product env sigma c
-  | CannotUnify (m,n,e) ->
-    let env, m, n = contract2 env m n in
-    explain_cannot_unify env sigma m n e
-  | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn
-  | CannotGeneralize ty -> explain_refiner_cannot_generalize env sigma ty
-  | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env sigma c id
-  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env sigma m n
-  | CannotFindWellTypedAbstraction (p,l,e) ->
-      explain_cannot_find_well_typed_abstraction env sigma p l
-        (Option.map (fun (env',e) -> explain_type_error env' sigma e) e)
-  | WrongAbstractionType (n,a,t,u) ->
-      explain_wrong_abstraction_type env sigma n a t u
-  | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n
-  | NonLinearUnification (m,c) -> explain_non_linear_unification env sigma m c
-  | TypingError t -> explain_type_error env sigma t
-  | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e
-  | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp
-(* Module errors *)
-
-open Modops
-
-let explain_not_match_error = function
-  | InductiveFieldExpected _ ->
-    strbrk "an inductive definition is expected"
-  | DefinitionFieldExpected ->
-    strbrk "a definition is expected"
-  | ModuleFieldExpected ->
-    strbrk "a module is expected"
-  | ModuleTypeFieldExpected ->
-    strbrk "a module type is expected"
-  | NotConvertibleInductiveField id | NotConvertibleConstructorField id ->
-    str "types given to " ++ pr_id id ++ str " differ"
-  | NotConvertibleBodyField ->
-    str "the body of definitions differs"
-  | NotConvertibleTypeField (env, typ1, typ2) ->
-    str "expected type" ++ spc ()  ++
-    quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++
-    str "but found type" ++ spc () ++
-    quote (Printer.safe_pr_lconstr_env env Evd.empty typ1)
-  | NotSameConstructorNamesField ->
-    str "constructor names differ"
-  | NotSameInductiveNameInBlockField ->
-    str "inductive types names differ"
-  | FiniteInductiveFieldExpected isfinite ->
-    str "type is expected to be " ++
-    str (if isfinite then "coinductive" else "inductive")
-  | InductiveNumbersFieldExpected n ->
-    str "number of inductive types differs"
-  | InductiveParamsNumberField n ->
-    str "inductive type has not the right number of parameters"
-  | RecordFieldExpected isrecord ->
-    str "type is expected " ++ str (if isrecord then "" else "not ") ++
-    str "to be a record"
-  | RecordProjectionsExpected nal ->
-    (if List.length nal >= 2 then str "expected projection names are "
-     else str "expected projection name is ") ++
-    pr_enum (function Name id -> pr_id id | _ -> str "_") nal
-  | NotEqualInductiveAliases ->
-    str "Aliases to inductive types do not match"
-  | NoTypeConstraintExpected ->
-    strbrk "a definition whose type is constrained can only be subtype " ++
-    strbrk "of a definition whose type is itself constrained"
-  | PolymorphicStatusExpected b ->
-    let status b = if b then str"polymorphic" else str"monomorphic" in
-      str "a " ++ status b ++ str" declaration was expected, but a " ++ 
-	status (not b) ++ str" declaration was found"
-  | IncompatibleInstances -> 
-    str"polymorphic universe instances do not match"
-  | IncompatibleUniverses incon ->
-    str"the universe constraints are inconsistent: " ++
-      Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon
-  | IncompatiblePolymorphism (env, t1, t2) ->
-    str "conversion of polymorphic values generates additional constraints: " ++
-      quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++
-      str "compared to " ++ spc () ++
-      quote (Printer.safe_pr_lconstr_env env Evd.empty t2)
-  | IncompatibleConstraints cst ->
-    str " the expected (polymorphic) constraints do not imply " ++
-      quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst)
-
-let explain_signature_mismatch l spec why =
-  str "Signature components for label " ++ pr_label l ++
-  str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "."
-
-let explain_label_already_declared l =
-  str "The label " ++ pr_label l ++ str " is already declared."
-
-let explain_application_to_not_path _ =
-  strbrk "A module cannot be applied to another module application or " ++
-  strbrk "with-expression; you must give a name to the intermediate result " ++
-  strbrk "module first."
-
-let explain_not_a_functor () =
-  str "Application of a non-functor."
-
-let explain_is_a_functor () =
-  str "Illegal use of a functor."
-
-let explain_incompatible_module_types mexpr1 mexpr2 =
-  let open Declarations in
-  let rec get_arg = function
-  | NoFunctor _ -> 0
-  | MoreFunctor (_, _, ty) -> succ (get_arg ty)
-  in
-  let len1 = get_arg mexpr1.mod_type in
-  let len2 = get_arg mexpr2.mod_type in
-  if len1 <> len2 then
-    str "Incompatible module types: module expects " ++ int len2 ++
-      str " arguments, found " ++ int len1 ++ str "."
-  else str "Incompatible module types."
-
-let explain_not_equal_module_paths mp1 mp2 =
-  str "Non equal modules."
-
-let explain_no_such_label l =
-  str "No such label " ++ pr_label l ++ str "."
-
-let explain_incompatible_labels l l' =
-  str "Opening and closing labels are not the same: " ++
-  pr_label l ++ str " <> " ++ pr_label l' ++ str "!"
-
-let explain_not_a_module s =
-  quote (str s) ++ str " is not a module."
-
-let explain_not_a_module_type s =
-  quote (str s) ++ str " is not a module type."
-
-let explain_not_a_constant l =
-  quote (pr_label l) ++ str " is not a constant."
-
-let explain_incorrect_label_constraint l =
-  str "Incorrect constraint for label " ++
-  quote (pr_label l) ++ str "."
-
-let explain_generative_module_expected l =
-  str "The module " ++ pr_label l ++ str " is not generative." ++
-  strbrk " Only components of generative modules can be changed" ++
-  strbrk " using the \"with\" construct."
-
-let explain_label_missing l s =
-  str "The field " ++ pr_label l ++ str " is missing in "
-  ++ str s ++ str "."
-
-let explain_include_restricted_functor mp =
-  let q = Nametab.shortest_qualid_of_module mp in
-  str "Cannot include the functor " ++ Libnames.pr_qualid q ++
-  strbrk " since it has a restricted signature. " ++
-  strbrk "You may name first an instance of this functor, and include it."
-
-let explain_module_error = function
-  | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err
-  | LabelAlreadyDeclared l -> explain_label_already_declared l
-  | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr
-  | NotAFunctor -> explain_not_a_functor ()
-  | IsAFunctor -> explain_is_a_functor ()
-  | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2
-  | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2
-  | NoSuchLabel l -> explain_no_such_label l
-  | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2
-  | NotAModule s -> explain_not_a_module s
-  | NotAModuleType s -> explain_not_a_module_type s
-  | NotAConstant l -> explain_not_a_constant l
-  | IncorrectWithConstraint l -> explain_incorrect_label_constraint l
-  | GenerativeModuleExpected l -> explain_generative_module_expected l
-  | LabelMissing (l,s) -> explain_label_missing l s
-  | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp
-
-(* Module internalization errors *)
-
-(*
-let explain_declaration_not_path _ =
-  str "Declaration is not a path."
-
-*)
-
-let explain_not_module_nor_modtype s =
-  quote (str s) ++ str " is not a module or module type."
-
-let explain_incorrect_with_in_module () =
-  str "The syntax \"with\" is not allowed for modules."
-
-let explain_incorrect_module_application () =
-  str "Illegal application to a module type."
-
-open Modintern
-
-let explain_module_internalization_error = function
-  | NotAModuleNorModtype s -> explain_not_module_nor_modtype s
-  | IncorrectWithInModule -> explain_incorrect_with_in_module ()
-  | IncorrectModuleApplication -> explain_incorrect_module_application ()
-
-(* Typeclass errors *)
-
-let explain_not_a_class env c =
-  pr_constr_env env Evd.empty c ++ str" is not a declared type class."
-
-let explain_unbound_method env cid id =
-  str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++
-  str"of class" ++ spc () ++ pr_global cid ++ str "."
-
-let pr_constr_exprs exprs =
-  hv 0 (List.fold_right
-	 (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps)
-         exprs (mt ()))
-
-let explain_mismatched_contexts env c i j =
-  str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
-    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++
-    fnl () ++ brk (1,1) ++
-    hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i)
-
-let explain_typeclass_error env = function
-  | NotAClass c -> explain_not_a_class env c
-  | UnboundMethod (cid, id) -> explain_unbound_method env cid id
-  | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j
-
-(* Refiner errors *)
-
-let explain_refiner_bad_type arg ty conclty =
-  str "Refiner was given an argument" ++ brk(1,1) ++
-  pr_lconstr arg ++ spc () ++
-  str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++
-  str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "."
-
-let explain_refiner_unresolved_bindings l =
-  str "Unable to find an instance for the " ++
-  str (String.plural (List.length l) "variable") ++ spc () ++
-  prlist_with_sep pr_comma pr_name l ++ str"."
-
-let explain_refiner_cannot_apply t harg =
-  str "In refiner, a term of type" ++ brk(1,1) ++
-  pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++
-  pr_lconstr harg ++ str "."
-
-let explain_refiner_not_well_typed c =
-  str "The term " ++ pr_lconstr c ++ str " is not well-typed."
-
-let explain_intro_needs_product () =
-  str "Introduction tactics needs products."
-
-let explain_does_not_occur_in c hyp =
-  str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++
-  str "does not occur in" ++ spc () ++ pr_id hyp ++ str "."
-
-let explain_non_linear_proof c =
-  str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++
-  spc () ++ str "because a metavariable has several occurrences."
-
-let explain_meta_in_type c =
-  str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++
-  str " of another meta"
-
-let explain_no_such_hyp id =
-  str "No such hypothesis: " ++ pr_id id
-
-let explain_refiner_error = function
-  | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
-  | UnresolvedBindings t -> explain_refiner_unresolved_bindings t
-  | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg
-  | NotWellTyped c -> explain_refiner_not_well_typed c
-  | IntroNeedsProduct -> explain_intro_needs_product ()
-  | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
-  | NonLinearProof c -> explain_non_linear_proof c
-  | MetaInType c -> explain_meta_in_type c
-  | NoSuchHyp id -> explain_no_such_hyp id
-
-(* Inductive errors *)
-
-let error_non_strictly_positive env c v =
-  let pc = pr_lconstr_env env Evd.empty c in
-  let pv = pr_lconstr_env env Evd.empty v in
-  str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
-  brk(1,1) ++ pc ++ str "."
-
-let error_ill_formed_inductive env c v =
-  let pc = pr_lconstr_env env Evd.empty c in
-  let pv = pr_lconstr_env env Evd.empty v in
-  str "Not enough arguments applied to the " ++ pv ++
-  str " in" ++ brk(1,1) ++ pc ++ str "."
-
-let error_ill_formed_constructor env id c v nparams nargs =
-  let pv = pr_lconstr_env env Evd.empty v in
-  let atomic = Int.equal (nb_prod c) 0 in
-  str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++
-  str "is not valid;" ++ brk(1,1) ++
-  strbrk (if atomic then "it must be " else "its conclusion must be ") ++
-  pv ++
-  (* warning: because of implicit arguments it is difficult to say which
-     parameters must be explicitly given *)
-  (if not (Int.equal nparams 0) then
-    strbrk " applied to its " ++ str (String.plural nparams "parameter")
-  else
-    mt()) ++
-  (if not (Int.equal nargs 0) then
-     str (if not (Int.equal nparams 0) then " and" else " applied") ++
-     strbrk " to some " ++ str (String.plural nargs "argument")
-   else
-     mt()) ++ str "."
-
-let pr_ltype_using_barendregt_convention_env env c =
-  (* Use goal_concl_style as an approximation of Barendregt's convention (?) *)
-  quote (pr_goal_concl_style_env env Evd.empty c)
-
-let error_bad_ind_parameters env c n v1 v2  =
-  let pc = pr_ltype_using_barendregt_convention_env env c in
-  let pv1 = pr_lconstr_env env Evd.empty v1 in
-  let pv2 = pr_lconstr_env env Evd.empty v2 in
-  str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
-  str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "."
-
-let error_same_names_types id =
-  str "The name" ++ spc () ++ pr_id id ++ spc () ++
-  str "is used more than once."
-
-let error_same_names_constructors id =
-  str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++
-  str "is used more than once."
-
-let error_same_names_overlap idl =
-  strbrk "The following names are used both as type names and constructor " ++
-  str "names:" ++ spc () ++
-  prlist_with_sep pr_comma pr_id idl ++ str "."
-
-let error_not_an_arity env c =
-  str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++
-  str "is not an arity."
-
-let error_bad_entry () =
-  str "Bad inductive definition."
-
-let error_large_non_prop_inductive_not_in_type () =
-  str "Large non-propositional inductive types must be in Type."
-
-(* Recursion schemes errors *)
-
-let error_not_allowed_case_analysis isrec kind i =
-  str (if isrec then "Induction" else "Case analysis") ++
-  strbrk " on sort " ++ pr_sort Evd.empty kind ++
-  strbrk " is not allowed for inductive definition " ++
-  pr_inductive (Global.env()) (fst i) ++ str "."
-
-let error_not_allowed_dependent_analysis isrec i =
-  str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++
-  strbrk " is not allowed for inductive definition " ++
-  pr_inductive (Global.env()) i ++ str "."
-
-let error_not_mutual_in_scheme ind ind' =
-  if eq_ind ind ind' then
-    str "The inductive type " ++ pr_inductive (Global.env()) ind ++
-    str " occurs twice."
-  else
-    str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++
-    str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++
-    str "are not mutually defined."
-
-(* Inductive constructions errors *)
-
-let explain_inductive_error = function
-  | NonPos (env,c,v) -> error_non_strictly_positive env c v
-  | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v
-  | NotConstructor (env,id,c,v,n,m) ->
-      error_ill_formed_constructor env id c v n m
-  | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2
-  | SameNamesTypes id -> error_same_names_types id
-  | SameNamesConstructors id -> error_same_names_constructors id
-  | SameNamesOverlap idl -> error_same_names_overlap idl
-  | NotAnArity (env, c) -> error_not_an_arity env c
-  | BadEntry -> error_bad_entry ()
-  | LargeNonPropInductiveNotInType ->
-      error_large_non_prop_inductive_not_in_type ()
-
-(* Recursion schemes errors *)
-
-let explain_recursion_scheme_error = function
-  | NotAllowedCaseAnalysis (isrec,k,i) ->
-      error_not_allowed_case_analysis isrec k i
-  | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind'
-  | NotAllowedDependentAnalysis (isrec, i) ->
-     error_not_allowed_dependent_analysis isrec i
-
-(* Pattern-matching errors *)
-
-let explain_bad_pattern env sigma cstr ty =
-  let env = make_all_name_different env in
-  let pt = pr_lconstr_env env sigma ty in
-  let pc = pr_constructor env cstr in
-  str "Found the constructor " ++ pc ++ brk(1,1) ++
-  str "while matching a term of type " ++ pt ++ brk(1,1) ++
-  str "which is not an inductive type."
-
-let explain_bad_constructor env cstr ind =
-  let pi = pr_inductive env ind in
-(*  let pc = pr_constructor env cstr in*)
-  let pt = pr_inductive env (inductive_of_constructor cstr) in
-  str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++
-  str "while a constructor of " ++ pi ++ brk(1,1) ++
-  str "is expected."
-
-let decline_string n s =
-  if Int.equal n 0 then str "no " ++ str s ++ str "s"
-  else if Int.equal n 1 then str "1 " ++ str s
-  else (int n ++ str " " ++ str s ++ str "s")
-
-let explain_wrong_numarg_constructor env cstr n =
-  str "The constructor " ++ pr_constructor env cstr ++
-  str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++
-  str ") expects " ++ decline_string n "argument" ++ str "."
-
-let explain_wrong_numarg_inductive env ind n =
-  str "The inductive type " ++ pr_inductive env ind ++
-  str " expects " ++ decline_string n "argument" ++ str "."
-
-let explain_unused_clause env pats =
-(* Without localisation
-  let s = if List.length pats > 1 then "s" else "" in
-  (str ("Unused clause with pattern"^s) ++ spc () ++
-    hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")")
-*)
-  str "This clause is redundant."
-
-let explain_non_exhaustive env pats =
-  str "Non exhaustive pattern-matching: no clause found for " ++
-  str (String.plural (List.length pats) "pattern") ++
-  spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats)
-
-let explain_cannot_infer_predicate env sigma typs =
-  let env = make_all_name_different env in
-  let pr_branch (cstr,typ) =
-    let cstr,_ = decompose_app cstr in
-    str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ
-  in
-  str "Unable to unify the types found in the branches:" ++
-  spc () ++ hov 0 (prlist_with_sep fnl pr_branch (Array.to_list typs))
-
-let explain_pattern_matching_error env sigma = function
-  | BadPattern (c,t) ->
-      explain_bad_pattern env sigma c t
-  | BadConstructor (c,ind) ->
-      explain_bad_constructor env c ind
-  | WrongNumargConstructor (c,n) ->
-      explain_wrong_numarg_constructor env c n
-  | WrongNumargInductive (c,n) ->
-      explain_wrong_numarg_inductive env c n
-  | UnusedClause tms ->
-      explain_unused_clause env tms
-  | NonExhaustive tms ->
-      explain_non_exhaustive env tms
-  | CannotInferPredicate typs ->
-      explain_cannot_infer_predicate env sigma typs
-
-let explain_reduction_tactic_error = function
-  | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) ->
-      str "The abstracted term" ++ spc () ++
-      quote (pr_goal_concl_style_env env sigma c) ++
-      spc () ++ str "is not well typed." ++ fnl () ++
-      explain_type_error env' Evd.empty e
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
deleted file mode 100644
index ced54fd2..00000000
--- a/toplevel/himsg.mli
+++ /dev/null
@@ -1,42 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Indtypes
-open Environ
-open Type_errors
-open Pretype_errors
-open Typeclasses_errors
-open Indrec
-open Cases
-open Logic
-
-(** This module provides functions to explain the type errors. *)
-
-val explain_type_error : env -> Evd.evar_map -> type_error -> std_ppcmds
-
-val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds
-
-val explain_inductive_error : inductive_error -> std_ppcmds
-
-val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds
-
-val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds
-
-val explain_refiner_error : refiner_error -> std_ppcmds
-
-val explain_pattern_matching_error :
-  env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds
-
-val explain_reduction_tactic_error :
-  Tacred.reduction_tactic_error -> std_ppcmds
-
-val explain_module_error : Modops.module_typing_error -> std_ppcmds
-
-val explain_module_internalization_error :
-  Modintern.module_internalization_error -> std_ppcmds
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
deleted file mode 100644
index 6d57a21d..00000000
--- a/toplevel/ind_tables.ml
+++ /dev/null
@@ -1,203 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* File created by Vincent Siles, Oct 2007, extended into a generic
-   support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *)
-
-(* This file provides support for registering inductive scheme builders,
-   declaring schemes and generating schemes on demand *)
-
-open Names
-open Mod_subst
-open Libobject
-open Nameops
-open Declarations
-open Term
-open CErrors
-open Util
-open Declare
-open Entries
-open Decl_kinds
-open Pp
-
-(**********************************************************************)
-(* Registering schemes in the environment *)
-
-type mutual_scheme_object_function =
-  internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants
-type individual_scheme_object_function =
-  internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants
-
-type 'a scheme_kind = string
-
-let scheme_map = Summary.ref Indmap.empty ~name:"Schemes"
-
-let pr_scheme_kind = Pp.str
-
-let cache_one_scheme kind (ind,const) =
-  let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in
-  scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map
-
-let cache_scheme (_,(kind,l)) =
-  Array.iter (cache_one_scheme kind) l
-
-let subst_one_scheme subst (ind,const) =
-  (* Remark: const is a def: the result of substitution is a constant *)
-  (subst_ind subst ind,subst_constant subst const)
-
-let subst_scheme (subst,(kind,l)) =
-  (kind,Array.map (subst_one_scheme subst) l)
-
-let discharge_scheme (_,(kind,l)) =
-  Some (kind,Array.map (fun (ind,const) ->
-    (Lib.discharge_inductive ind,Lib.discharge_con const)) l)
-
-let inScheme : string * (inductive * constant) array -> obj =
-  declare_object {(default_object "SCHEME") with
-                    cache_function = cache_scheme;
-                    load_function = (fun _ -> cache_scheme);
-                    subst_function = subst_scheme;
-		    classify_function = (fun obj -> Substitute obj);
-		    discharge_function = discharge_scheme}
-
-(**********************************************************************)
-(* The table of scheme building functions *)
-
-type individual
-type mutual
-
-type scheme_object_function =
-  | MutualSchemeFunction of mutual_scheme_object_function
-  | IndividualSchemeFunction of individual_scheme_object_function
-
-let scheme_object_table =
-  (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t)
-
-let declare_scheme_object s aux f =
-  let () =
-    if not (Id.is_valid ("ind" ^ s)) then
-      error ("Illegal induction scheme suffix: " ^ s)
-  in
-  let key = if String.is_empty aux then s else aux in
-  try
-    let _ = Hashtbl.find scheme_object_table key in
-(*    let aux_msg = if aux="" then "" else " (with key "^aux^")" in*)
-    errorlabstrm "IndTables.declare_scheme_object"
-      (str "Scheme object " ++ str key ++ str " already declared.")
-  with Not_found ->
-    Hashtbl.add scheme_object_table key (s,f);
-    key
-
-let declare_mutual_scheme_object s ?(aux="") f =
-  declare_scheme_object s aux (MutualSchemeFunction f)
-
-let declare_individual_scheme_object s ?(aux="") f =
-  declare_scheme_object s aux (IndividualSchemeFunction f)
-
-(**********************************************************************)
-(* Defining/retrieving schemes *)
-
-let declare_scheme kind indcl =
-  Lib.add_anonymous_leaf (inScheme (kind,indcl))
-
-let () = Declare.set_declare_scheme declare_scheme
-
-let is_visible_name id =
-  try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true
-  with Not_found -> false
-
-let compute_name internal id =
-  match internal with
-  | UserAutomaticRequest | UserIndividualRequest -> id
-  | InternalTacticRequest ->
-      Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name
-
-let define internal id c p univs =
-  let fd = declare_constant ~internal in
-  let id = compute_name internal id in
-  let ctx = Evd.normalize_evar_universe_context univs in
-  let c = Vars.subst_univs_fn_constr 
-    (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in
-  let entry = {
-    const_entry_body =
-      Future.from_val ((c,Univ.ContextSet.empty),
-                       Safe_typing.empty_private_constants);
-    const_entry_secctx = None;
-    const_entry_type = None;
-    const_entry_polymorphic = p;
-    const_entry_universes = Evd.evar_context_universe_context ctx;
-    const_entry_opaque = false;
-    const_entry_inline_code = false;
-    const_entry_feedback = None;
-  } in
-  let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in
-  let () = match internal with
-    | InternalTacticRequest -> ()
-    | _-> definition_message id
-  in
-  kn
-
-let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) =
-  let (c, ctx), eff = f mode ind in
-  let mib = Global.lookup_mind mind in
-  let id = match idopt with
-    | Some id -> id
-    | None -> add_suffix mib.mind_packets.(i).mind_typename suff in
-  let const = define mode id c mib.mind_polymorphic ctx in
-  declare_scheme kind [|ind,const|];
-  const, Safe_typing.add_private
-     (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind,const]) eff
-
-let define_individual_scheme kind mode names (mind,i as ind) =
-  match Hashtbl.find scheme_object_table kind with
-  | _,MutualSchemeFunction f -> assert false
-  | s,IndividualSchemeFunction f ->
-      define_individual_scheme_base kind s f mode names ind
-
-let define_mutual_scheme_base kind suff f mode names mind =
-  let (cl, ctx), eff = f mode mind in
-  let mib = Global.lookup_mind mind in
-  let ids = Array.init (Array.length mib.mind_packets) (fun i ->
-      try Int.List.assoc i names
-      with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in
-  let consts = Array.map2 (fun id cl -> 
-     define mode id cl mib.mind_polymorphic ctx) ids cl in
-  let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in
-  declare_scheme kind schemes;
-  consts,
-  Safe_typing.add_private 
-    (Safe_typing.private_con_of_scheme
-      kind (Global.safe_env()) (Array.to_list schemes))
-    eff 
-
-let define_mutual_scheme kind mode names mind =
-  match Hashtbl.find scheme_object_table kind with
-  | _,IndividualSchemeFunction _ -> assert false
-  | s,MutualSchemeFunction f ->
-      define_mutual_scheme_base kind s f mode names mind
-
-let find_scheme_on_env_too kind ind =
-  let s = String.Map.find kind (Indmap.find ind !scheme_map) in
-  s, Safe_typing.add_private
-      (Safe_typing.private_con_of_scheme
-            kind (Global.safe_env()) [ind, s])
-      Safe_typing.empty_private_constants
-
-let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) =
-  try find_scheme_on_env_too kind ind
-  with Not_found ->
-  match Hashtbl.find scheme_object_table kind with
-  | s,IndividualSchemeFunction f ->
-      define_individual_scheme_base kind s f mode None ind
-  | s,MutualSchemeFunction f ->
-      let ca, eff = define_mutual_scheme_base kind s f mode [] mind in
-      ca.(i), eff
-
-let check_scheme kind ind =
-  try let _ = find_scheme_on_env_too kind ind in true
-  with Not_found -> false
diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli
deleted file mode 100644
index 20f30d6d..00000000
--- a/toplevel/ind_tables.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Names
-open Declare
-
-(** This module provides support for registering inductive scheme builders,
-   declaring schemes and generating schemes on demand *)
-
-(** A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *)
-
-type mutual
-type individual
-type 'a scheme_kind
-
-type mutual_scheme_object_function =
-  internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants
-type individual_scheme_object_function =
-  internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants
-
-(** Main functions to register a scheme builder *)
-
-val declare_mutual_scheme_object : string -> ?aux:string ->
-  mutual_scheme_object_function -> mutual scheme_kind
-
-val declare_individual_scheme_object : string -> ?aux:string ->
-  individual_scheme_object_function ->
-  individual scheme_kind
-
-(** Force generation of a (mutually) scheme with possibly user-level names *)
-
-val define_individual_scheme : individual scheme_kind -> 
-  internal_flag (** internal *) ->
-  Id.t option -> inductive -> constant * Safe_typing.private_constants
-
-val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) ->
-  (int * Id.t) list -> mutual_inductive -> constant array * Safe_typing.private_constants
-
-(** Main function to retrieve a scheme in the cache or to generate it *)
-val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Safe_typing.private_constants
-
-val check_scheme : 'a scheme_kind -> inductive -> bool
-
-
-val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
deleted file mode 100644
index e8ea617f..00000000
--- a/toplevel/indschemes.ml
+++ /dev/null
@@ -1,524 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Created by Hugo Herbelin from contents related to inductive schemes
-   initially developed by Christine Paulin (induction schemes), Vincent
-   Siles (decidable equality and boolean equality) and Matthieu Sozeau
-   (combined scheme) in file command.ml, Sep 2009 *)
-
-(* This file provides entry points for manually or automatically
-   declaring new schemes *)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Declarations
-open Entries
-open Term
-open Inductive
-open Decl_kinds
-open Indrec
-open Declare
-open Libnames
-open Globnames
-open Goptions
-open Nameops
-open Termops
-open Pretyping
-open Nametab
-open Smartlocate
-open Vernacexpr
-open Ind_tables
-open Auto_ind_decl
-open Eqschemes
-open Elimschemes
-open Context.Rel.Declaration
-
-(* Flags governing automatic synthesis of schemes *)
-
-let elim_flag = ref true
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic declaration of induction schemes";
-      optkey   = ["Elimination";"Schemes"];
-      optread  = (fun () -> !elim_flag) ;
-      optwrite = (fun b -> elim_flag := b) }
-
-let bifinite_elim_flag = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic declaration of induction schemes for non-recursive types";
-      optkey   = ["Nonrecursive";"Elimination";"Schemes"];
-      optread  = (fun () -> !bifinite_elim_flag) ;
-      optwrite = (fun b -> bifinite_elim_flag := b) }
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = true; (* compatibility 2014-09-03*)
-      optname  = "automatic declaration of induction schemes for non-recursive types";
-      optkey   = ["Record";"Elimination";"Schemes"];
-      optread  = (fun () -> !bifinite_elim_flag) ;
-      optwrite = (fun b -> bifinite_elim_flag := b) }
-
-let case_flag = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic declaration of case analysis schemes";
-      optkey   = ["Case";"Analysis";"Schemes"];
-      optread  = (fun () -> !case_flag) ;
-      optwrite = (fun b -> case_flag := b) }
-
-let eq_flag = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic declaration of boolean equality";
-      optkey   = ["Boolean";"Equality";"Schemes"];
-      optread  = (fun () -> !eq_flag) ;
-      optwrite = (fun b -> eq_flag := b) }
-let _ = (* compatibility *)
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = true;
-      optname  = "automatic declaration of boolean equality";
-      optkey   = ["Equality";"Scheme"];
-      optread  = (fun () -> !eq_flag) ;
-      optwrite = (fun b -> eq_flag := b) }
-
-let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2
-
-let eq_dec_flag = ref false 
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic declaration of decidable equality";
-      optkey   = ["Decidable";"Equality";"Schemes"];
-      optread  = (fun () -> !eq_dec_flag) ;
-      optwrite = (fun b -> eq_dec_flag := b) }
-
-let rewriting_flag = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  ="automatic declaration of rewriting schemes for equality types";
-      optkey   = ["Rewriting";"Schemes"];
-      optread  = (fun () -> !rewriting_flag) ;
-      optwrite = (fun b -> rewriting_flag := b) }
-
-(* Util *)
-
-let define id internal ctx c t =
-  let f = declare_constant ~internal in
-  let kn = f id
-    (DefinitionEntry
-      { const_entry_body = c;
-        const_entry_secctx = None;
-        const_entry_type = t;
-	const_entry_polymorphic = Flags.is_universe_polymorphism ();
-	const_entry_universes = snd (Evd.universe_context ctx);
-        const_entry_opaque = false;
-        const_entry_inline_code = false;
-        const_entry_feedback = None;
-      },
-      Decl_kinds.IsDefinition Scheme) in
-  definition_message id;
-  kn
-
-(* Boolean equality *)
-
-let declare_beq_scheme_gen internal names kn =
-  ignore (define_mutual_scheme beq_scheme_kind internal names kn)
-
-let alarm what internal msg =
-  let debug = false in
-  match internal with
-  | UserAutomaticRequest
-  | InternalTacticRequest ->
-    (if debug then
-      Feedback.msg_debug
-	(hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None
-  | _ -> Some msg
-
-let try_declare_scheme what f internal names kn =
-  try f internal names kn
-  with e ->
-  let e = CErrors.push e in
-  let msg = match fst e with
-    | ParameterWithoutEquality cst ->
-	alarm what internal
-	  (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++
-	   str".")
-    | InductiveWithProduct ->
-	alarm what internal
-	  (str "Unable to decide equality of functional arguments.")
-    | InductiveWithSort ->
-	alarm what internal
-	  (str "Unable to decide equality of type arguments.")
-    | NonSingletonProp ind ->
-	alarm what internal
-	  (str "Cannot extract computational content from proposition " ++
-	   quote (Printer.pr_inductive (Global.env()) ind) ++ str ".")
-    | EqNotFound (ind',ind) ->
-	alarm what internal
-	  (str "Boolean equality on " ++
-	   quote (Printer.pr_inductive (Global.env()) ind') ++
-	   strbrk " is missing.")
-    | UndefinedCst s ->
-	alarm what internal
-	  (strbrk "Required constant " ++ str s ++ str " undefined.")
-    | AlreadyDeclared msg ->
-        alarm what internal (msg ++ str ".")
-    | DecidabilityMutualNotSupported ->
-        alarm what internal
-          (str "Decidability lemma for mutual inductive types not supported.")
-    | e when CErrors.noncritical e ->
-        alarm what internal
-	  (str "Unexpected error during scheme creation: " ++ CErrors.print e)
-    | _ -> iraise e
-  in
-  match msg with
-  | None -> ()
-  | Some msg -> iraise (UserError ("", msg), snd e)
-
-let beq_scheme_msg mind =
-  let mib = Global.lookup_mind mind in
-  (* TODO: mutual inductive case *)
-  str "Boolean equality on " ++
-    pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind))
-    (List.init (Array.length mib.mind_packets) (fun i -> (mind,i)))
-
-let declare_beq_scheme_with l kn =
-  try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserIndividualRequest l kn
-
-let try_declare_beq_scheme kn =
-  (* TODO: handle Fix, eventually handle
-      proof-irrelevance; improve decidability by depending on decidability
-      for the parameters rather than on the bl and lb properties *)
-  try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserAutomaticRequest [] kn
-
-let declare_beq_scheme = declare_beq_scheme_with []
-
-(* Case analysis schemes *)
-let declare_one_case_analysis_scheme ind =
-  let (mib,mip) = Global.lookup_inductive ind in
-  let kind = inductive_sort_family mip in
-  let dep =
-    if kind == InProp then case_scheme_kind_from_prop
-    else if not (Inductiveops.has_dependent_elim mib) then
-      case_scheme_kind_from_type
-    else case_dep_scheme_kind_from_type in
-  let kelim = elim_sorts (mib,mip) in
-    (* in case the inductive has a type elimination, generates only one
-       induction scheme, the other ones share the same code with the
-       apropriate type *)
-  if Sorts.List.mem InType kelim then
-    ignore (define_individual_scheme dep UserAutomaticRequest None ind)
-
-(* Induction/recursion schemes *)
-
-let kinds_from_prop =
-  [InType,rect_scheme_kind_from_prop;
-   InProp,ind_scheme_kind_from_prop;
-   InSet,rec_scheme_kind_from_prop]
-
-let kinds_from_type =
-  [InType,rect_dep_scheme_kind_from_type;
-   InProp,ind_dep_scheme_kind_from_type;
-   InSet,rec_dep_scheme_kind_from_type]
-
-let nondep_kinds_from_type =
-  [InType,rect_scheme_kind_from_type;
-   InProp,ind_scheme_kind_from_type;
-   InSet,rec_scheme_kind_from_type]
-
-let declare_one_induction_scheme ind =
-  let (mib,mip) = Global.lookup_inductive ind in
-  let kind = inductive_sort_family mip in
-  let from_prop = kind == InProp in
-  let depelim = Inductiveops.has_dependent_elim mib in
-  let kelim = elim_sorts (mib,mip) in
-  let elims =
-    List.map_filter (fun (sort,kind) ->
-      if Sorts.List.mem sort kelim then Some kind else None)
-      (if from_prop then kinds_from_prop
-       else if depelim then kinds_from_type
-       else nondep_kinds_from_type) in
-  List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind))
-    elims
-
-let declare_induction_schemes kn =
-  let mib = Global.lookup_mind kn in
-  if mib.mind_finite <> Decl_kinds.CoFinite then begin
-    for i = 0 to Array.length mib.mind_packets - 1 do
-      declare_one_induction_scheme (kn,i);
-    done;
-  end
-
-(* Decidable equality *)
-
-let declare_eq_decidability_gen internal names kn =
-  let mib = Global.lookup_mind kn in
-  if mib.mind_finite <> Decl_kinds.CoFinite then
-    ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn)
-
-let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *)
-  str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind)
-
-let declare_eq_decidability_scheme_with l kn =
-  try_declare_scheme (eq_dec_scheme_msg (kn,0))
-    declare_eq_decidability_gen UserIndividualRequest l kn
-
-let try_declare_eq_decidability kn =
-  try_declare_scheme (eq_dec_scheme_msg (kn,0))
-    declare_eq_decidability_gen UserAutomaticRequest [] kn
-
-let declare_eq_decidability = declare_eq_decidability_scheme_with []
-
-let ignore_error f x =
-  try ignore (f x) with e when CErrors.noncritical e -> ()
-
-let declare_rewriting_schemes ind =
-  if Hipattern.is_inductive_equality ind then begin
-    ignore (define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind);
-    ignore (define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind);
-    ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind
-      UserAutomaticRequest None ind);
-    (* These ones expect the equality to be symmetric; the first one also *)
-    (* needs eq *)
-    ignore_error (define_individual_scheme rew_l2r_scheme_kind UserAutomaticRequest None) ind;
-    ignore_error
-      (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind;
-    ignore_error
-      (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind
-  end
-
-let warn_cannot_build_congruence =
-  CWarnings.create ~name:"cannot-build-congruence" ~category:"schemes"
-         (fun () ->
-          strbrk "Cannot build congruence scheme because eq is not found")
-
-let declare_congr_scheme ind =
-  if Hipattern.is_equality_type (mkInd ind) then begin
-    if
-      try Coqlib.check_required_library Coqlib.logic_module_name; true
-      with e when CErrors.noncritical e -> false
-    then
-      ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind)
-    else
-      warn_cannot_build_congruence ()
-  end
-
-let declare_sym_scheme ind =
-  if Hipattern.is_inductive_equality ind then
-    (* Expect the equality to be symmetric *)
-    ignore_error (define_individual_scheme sym_scheme_kind UserAutomaticRequest None) ind
-
-(* Scheme command *)
-
-let smart_global_inductive y = smart_global_inductive y
-let rec split_scheme l =
- let env = Global.env() in
- match l with
-  | [] -> [],[]
-  | (Some id,t)::q -> let l1,l2 = split_scheme q in
-    ( match t with
-      | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
-      | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
-      | EqualityScheme  x -> l1,((Some id,smart_global_inductive x)::l2)
-    )
-(*
- if no name has been provided, we build one from the types of the ind
-requested
-*)
-  | (None,t)::q ->
-      let l1,l2 = split_scheme q in
-      let names inds recs isdep y z =
-        let ind = smart_global_inductive y in
-        let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in
-        let z' = interp_elimination_sort z in
-        let suffix = (
-          match sort_of_ind with
-          | InProp ->
-              if isdep then (match z' with
-              | InProp -> inds ^ "_dep"
-              | InSet  -> recs ^ "_dep"
-              | InType -> recs ^ "t_dep")
-              else ( match z' with
-              | InProp -> inds
-              | InSet -> recs
-              | InType -> recs ^ "t" )
-          | _ ->
-              if isdep then (match z' with
-              | InProp -> inds
-              | InSet -> recs
-              | InType -> recs ^ "t" )
-              else (match z' with
-              | InProp -> inds ^ "_nodep"
-              | InSet -> recs ^ "_nodep"
-              | InType -> recs ^ "t_nodep")
-        ) in
-        let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
-        let newref = (Loc.ghost,newid) in
-          ((newref,isdep,ind,z)::l1),l2
-      in
-	match t with
-	| CaseScheme (x,y,z) -> names "_case" "_case" x y z
-	| InductionScheme (x,y,z) -> names "_ind" "_rec" x y z
-	| EqualityScheme  x -> l1,((None,smart_global_inductive x)::l2)
-	    
-
-let do_mutual_induction_scheme lnamedepindsort =
-  let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
-  and env0 = Global.env() in
-  let sigma, lrecspec, _ =
-    List.fold_right
-      (fun (_,dep,ind,sort) (evd, l, inst) -> 
-       let evd, indu, inst =
-	 match inst with
-	 | None ->
-	    let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in
-	    let ctxs = Univ.ContextSet.of_context ctx in
-	    let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in
-	    let u = Univ.UContext.instance ctx in
-	      evd, (ind,u), Some u
-	 | Some ui -> evd, (ind, ui), inst
-       in
-          (evd, (indu,dep,interp_elimination_sort sort) :: l, inst))
-    lnamedepindsort (Evd.from_env env0,[],None)
-  in
-  let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
-  let declare decl fi lrecref =
-    let decltype = Retyping.get_type_of env0 sigma decl in
-    let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
-    let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in
-    ConstRef cst :: lrecref
-  in
-  let _ = List.fold_right2 declare listdecl lrecnames [] in
-  fixpoint_message None lrecnames
-
-let get_common_underlying_mutual_inductive = function
-  | [] -> assert false
-  | (id,(mind,i as ind))::l as all ->
-      match List.filter (fun (_,(mind',_)) -> not (eq_mind mind mind')) l with
-      | (_,ind')::_ ->
-	  raise (RecursionSchemeError (NotMutualInScheme (ind,ind')))
-      | [] ->
-	  if not (List.distinct_f Int.compare (List.map snd (List.map snd all)))
-          then error "A type occurs twice";
-	  mind,
-	  List.map_filter
-	    (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all
-
-let do_scheme l =
-  let ischeme,escheme = split_scheme l in
-(* we want 1 kind of scheme at a time so we check if the user
-tried to declare different schemes at once *)
-    if not (List.is_empty ischeme) && not (List.is_empty escheme)
-    then
-      error "Do not declare equality and induction scheme at the same time."
-    else (
-      if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme
-      else
-	let mind,l = get_common_underlying_mutual_inductive escheme in
-	declare_beq_scheme_with l mind;
-	declare_eq_decidability_scheme_with l mind
-    )
-
-(**********************************************************************)
-(* Combined scheme *)
-(* Matthieu Sozeau, Dec 2006 *)
-
-let list_split_rev_at index l =
-  let rec aux i acc = function
-      hd :: tl when Int.equal i index -> acc, tl
-    | hd :: tl -> aux (succ i) (hd :: acc) tl
-    | [] -> failwith "List.split_when: Invalid argument"
-  in aux 0 [] l
-
-let fold_left' f = function
-    [] -> invalid_arg "fold_left'"
-  | hd :: tl -> List.fold_left f hd tl
-
-let build_combined_scheme env schemes =
-  let defs = List.map (fun cst -> (* FIXME *)
-    let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in
-      (c, Typeops.type_of_constant_in env c)) schemes in
-(*   let nschemes = List.length schemes in *)
-  let find_inductive ty =
-    let (ctx, arity) = decompose_prod ty in
-    let (_, last) = List.hd ctx in
-      match kind_of_term last with
-	| App (ind, args) ->
-	    let ind = destInd ind in
-	    let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in
-	      ctx, ind, spec.mind_nrealargs
-	| _ -> ctx, destInd last, 0
-  in
-  let (c, t) = List.hd defs in
-  let ctx, ind, nargs = find_inductive t in
-  (* Number of clauses, including the predicates quantification *)
-  let prods = nb_prod t - (nargs + 1) in
-  let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in
-  let relargs = rel_vect 0 prods in
-  let concls = List.rev_map
-    (fun (cst, t) -> (* FIXME *)
-      mkApp(mkConstU cst, relargs),
-      snd (decompose_prod_n prods t)) defs in
-  let concl_bod, concl_typ =
-    fold_left'
-      (fun (accb, acct) (cst, x) ->
-	mkApp (coqconj, [| x; acct; cst; accb |]),
-	mkApp (coqand, [| x; acct |])) concls
-  in
-  let ctx, _ =
-    list_split_rev_at prods
-      (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in
-  let typ = it_mkProd_wo_LetIn concl_typ ctx in
-  let body = it_mkLambda_or_LetIn concl_bod ctx in
-  (body, typ)
-
-let do_combined_scheme name schemes =
-  let csts =
-    List.map (fun x ->
-		let refe = Ident x in
-		let qualid = qualid_of_reference refe in
-		try Nametab.locate_constant (snd qualid)
-                with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared."))
-      schemes
-  in
-  let body,typ = build_combined_scheme (Global.env ()) csts in
-  let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
-  ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ));
-  fixpoint_message None [snd name]
-
-(**********************************************************************)
-
-let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done
-
-let declare_default_schemes kn =
-  let mib = Global.lookup_mind kn in
-  let n = Array.length mib.mind_packets in
-  if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag)
-     && mib.mind_typing_flags.check_guarded then
-    declare_induction_schemes kn;
-  if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n;
-  if is_eq_flag() then try_declare_beq_scheme kn;
-  if !eq_dec_flag then try_declare_eq_decidability kn;
-  if !rewriting_flag then map_inductive_block declare_congr_scheme kn n;
-  if !rewriting_flag then map_inductive_block declare_sym_scheme kn n;
-  if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
deleted file mode 100644
index e5d79fd5..00000000
--- a/toplevel/indschemes.mli
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Loc
-open Names
-open Term
-open Environ
-open Vernacexpr
-open Misctypes
-
-(** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
-
-(** Build and register the boolean equalities associated to an inductive type *)
-
-val declare_beq_scheme : mutual_inductive -> unit
-
-val declare_eq_decidability : mutual_inductive -> unit
-
-(** Build and register a congruence scheme for an equality-like inductive type *)
-
-val declare_congr_scheme : inductive -> unit
-
-(** Build and register rewriting schemes for an equality-like inductive type *)
-
-val declare_rewriting_schemes : inductive -> unit
-
-(** Mutual Minimality/Induction scheme *)
-
-val do_mutual_induction_scheme :
-  (Id.t located * bool * inductive * glob_sort) list -> unit
-
-(** Main calls to interpret the Scheme command *)
-
-val do_scheme : (Id.t located option * scheme) list -> unit
-
-(** Combine a list of schemes into a conjunction of them *)
-
-val build_combined_scheme : env -> constant list -> constr * types
-
-val do_combined_scheme : Id.t located -> Id.t located list -> unit
-
-(** Hook called at each inductive type definition *)
-
-val declare_default_schemes : mutual_inductive -> unit
diff --git a/toplevel/locality.ml b/toplevel/locality.ml
deleted file mode 100644
index 154f787e..00000000
--- a/toplevel/locality.ml
+++ /dev/null
@@ -1,107 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-
-(** * Managing locality *)
-
-let local_of_bool = function
-  | true -> Decl_kinds.Local
-  | false -> Decl_kinds.Global
-
-let check_locality locality_flag =
-  match locality_flag with
-  | Some b ->
-    let s = if b then "Local" else "Global" in
-    CErrors.errorlabstrm "Locality.check_locality"
-      (str "This command does not support the \"" ++ str s ++ str "\" prefix.")
-  | None -> ()
-
-(** Extracting the locality flag *)
-
-(* Commands which supported an inlined Local flag *)
-
-let warn_deprecated_local_syntax =
-  CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated"
-         (fun () ->
-          Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.")
-
-let enforce_locality_full locality_flag local =
-  let local =
-    match locality_flag with
-    | Some false when local ->
-	CErrors.error "Cannot be simultaneously Local and Global."
-    | Some true when local ->
-	CErrors.error "Use only prefix \"Local\"."
-    | None ->
-	if local then begin
-	    warn_deprecated_local_syntax ();
-	    Some true
-	end else
-	None
-    | Some b -> Some b in
-  local
-
-(** Positioning locality for commands supporting discharging and export
-     outside of modules *)
-
-(* For commands whose default is to discharge and export:
-   Global is the default and is neutral;
-   Local in a section deactivates discharge,
-   Local not in a section deactivates export *)
-let make_non_locality = function Some false -> false | _ -> true
-
-let make_locality = function Some true -> true | _ -> false
-
-let enforce_locality locality_flag local =
-   make_locality (enforce_locality_full locality_flag local)
-
-let enforce_locality_exp locality_flag local =
-  match locality_flag, local with
-  | None, Some local -> local
-  | Some b, None -> local_of_bool b
-  | None, None -> Decl_kinds.Global
-  | Some _, Some _ -> CErrors.error "Local non allowed in this case"
-
-(* For commands whose default is to not discharge but to export:
-   Global in sections forces discharge, Global not in section is the default;
-   Local in sections is the default, Local not in section forces non-export *)
-
-let make_section_locality =
-  function Some b -> b | None -> Lib.sections_are_opened ()
-
-let enforce_section_locality locality_flag local =
-  make_section_locality (enforce_locality_full locality_flag local)
-
-(** Positioning locality for commands supporting export but not discharge *)
-
-(* For commands whose default is to export (if not in section):
-   Global in sections is forbidden, Global not in section is neutral;
-   Local in sections is the default, Local not in section forces non-export *)
-
-let make_module_locality = function
-  | Some false ->
-      if Lib.sections_are_opened () then
-	CErrors.error
-	  "This command does not support the Global option in sections.";
-      false
-  | Some true -> true
-  | None -> false
-
-let enforce_module_locality locality_flag local =
-  make_module_locality (enforce_locality_full locality_flag local)
-
-module LocalityFixme = struct
-  let locality = ref None
-  let set l = locality := l
-  let consume () =
-    let l = !locality in
-    locality := None;
-    l
-  let assert_consumed () = check_locality !locality
-end
diff --git a/toplevel/locality.mli b/toplevel/locality.mli
deleted file mode 100644
index 2ec392ee..00000000
--- a/toplevel/locality.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** * Managing locality *)
-
-(** Commands which supported an inlined Local flag *)
-
-val enforce_locality_full : bool option -> bool -> bool option
-
-(** * Positioning locality for commands supporting discharging and export
-    outside of modules *)
-
-(** For commands whose default is to discharge and export:
-    Global is the default and is neutral;
-    Local in a section deactivates discharge,
-    Local not in a section deactivates export *)
-
-val make_locality : bool option -> bool
-val make_non_locality : bool option -> bool
-val enforce_locality : bool option -> bool -> bool
-val enforce_locality_exp :
-  bool option -> Decl_kinds.locality option -> Decl_kinds.locality
-
-(** For commands whose default is to not discharge but to export:
-    Global in sections forces discharge, Global not in section is the default;
-    Local in sections is the default, Local not in section forces non-export *)
-
-val make_section_locality : bool option -> bool
-val enforce_section_locality : bool option -> bool -> bool
-
-(** * Positioning locality for commands supporting export but not discharge *)
-
-(** For commands whose default is to export (if not in section):
-    Global in sections is forbidden, Global not in section is neutral;
-    Local in sections is the default, Local not in section forces non-export *)
-
-val make_module_locality : bool option -> bool
-val enforce_module_locality : bool option -> bool -> bool
-
-(* This is the old imperative interface that is still used for
- * VernacExtend vernaculars.  Time permitting this could be trashed too *)
-module LocalityFixme : sig
-  val set : bool option -> unit
-  val consume : unit -> bool option
-  val assert_consumed : unit -> unit
-end
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
deleted file mode 100644
index 008d5cf9..00000000
--- a/toplevel/metasyntax.ml
+++ /dev/null
@@ -1,1379 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Flags
-open CErrors
-open Util
-open Names
-open Constrexpr
-open Constrexpr_ops
-open Notation_term
-open Notation_ops
-open Ppextend
-open Extend
-open Libobject
-open Constrintern
-open Vernacexpr
-open Pcoq
-open Libnames
-open Tok
-open Egramcoq
-open Notation
-open Nameops
-
-(**********************************************************************)
-(* Tokens                                                             *)
-
-let cache_token (_,s) = CLexer.add_keyword s
-
-let inToken : string -> obj =
-  declare_object {(default_object "TOKEN") with
-       open_function = (fun i o -> if Int.equal i 1 then cache_token o);
-       cache_function = cache_token;
-       subst_function = Libobject.ident_subst_function;
-       classify_function = (fun o -> Substitute o)}
-
-let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
-
-(**********************************************************************)
-(* Printing grammar entries                                           *)
-
-let entry_buf = Buffer.create 64
-
-let pr_entry e =
-  let () = Buffer.clear entry_buf in
-  let ft = Format.formatter_of_buffer entry_buf in
-  let () = Gram.entry_print ft e in
-  str (Buffer.contents entry_buf)
-
-let pr_grammar = function
-  | "constr" | "operconstr" | "binder_constr" ->
-      str "Entry constr is" ++ fnl () ++
-      pr_entry Pcoq.Constr.constr ++
-      str "and lconstr is" ++ fnl () ++
-      pr_entry Pcoq.Constr.lconstr ++
-      str "where binder_constr is" ++ fnl () ++
-      pr_entry Pcoq.Constr.binder_constr ++
-      str "and operconstr is" ++ fnl () ++
-      pr_entry Pcoq.Constr.operconstr
-  | "pattern" ->
-      pr_entry Pcoq.Constr.pattern
-  | "tactic" ->
-      str "Entry tactic_expr is" ++ fnl () ++
-      pr_entry Pcoq.Tactic.tactic_expr ++
-      str "Entry binder_tactic is" ++ fnl () ++
-      pr_entry Pcoq.Tactic.binder_tactic ++
-      str "Entry simple_tactic is" ++ fnl () ++
-      pr_entry Pcoq.Tactic.simple_tactic ++
-      str "Entry tactic_arg is" ++ fnl () ++
-      pr_entry Pcoq.Tactic.tactic_arg
-  | "vernac" ->
-      str "Entry vernac is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.vernac ++
-      str "Entry command is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.command ++
-      str "Entry syntax is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.syntax ++
-      str "Entry gallina is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.gallina ++
-      str "Entry gallina_ext is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.gallina_ext
-  | _ -> error "Unknown or unprintable grammar entry."
-
-(**********************************************************************)
-(* Parse a format (every terminal starting with a letter or a single
-   quote (except a single quote alone) must be quoted) *)
-
-let parse_format ((loc, str) : lstring) =
-  let str = " "^str in
-  let l = String.length str in
-  let push_token a = function
-    | cur::l -> (a::cur)::l
-    | [] -> [[a]] in
-  let push_white n l =
-    if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
-  let close_box i b = function
-    | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
-    | _ -> error "Non terminated box in format." in
-  let close_quotation i =
-    if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ')
-    then i+1
-    else error "Incorrectly terminated quoted expression." in
-  let rec spaces n i =
-    if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1)
-    else n in
-  let rec nonspaces quoted n i =
-    if i < String.length str && str.[i] != ' ' then
-      if str.[i] == '\'' && quoted &&
-        (i+1 >= String.length str || str.[i+1] == ' ')
-      then if Int.equal n 0 then error "Empty quoted token." else n
-      else nonspaces quoted (n+1) (i+1)
-    else
-      if quoted then error "Spaces are not allowed in (quoted) symbols."
-      else n in
-  let rec parse_non_format i =
-    let n = nonspaces false 0 i in
-    push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n))
-  and parse_quoted n i =
-    if i < String.length str then match str.[i] with
-      (* Parse " // " *)
-      | '/' when i <= String.length str && str.[i+1] == '/' ->
-          (* We forget the useless n spaces... *)
-	  push_token (UnpCut PpFnl)
-            (parse_token (close_quotation (i+2)))
-      (* Parse " .. / .. " *)
-      | '/' when i <= String.length str ->
-	  let p = spaces 0 (i+1) in
-	  push_token (UnpCut (PpBrk (n,p)))
-            (parse_token (close_quotation (i+p+1)))
-      | c ->
-      (* The spaces are real spaces *)
-      push_white n (match c with
-      | '[' ->
-	  if i <= String.length str then match str.[i+1] with
-	    (* Parse " [h .. ",  *)
-	    | 'h' when i+1 <= String.length str && str.[i+2] == 'v' ->
-		  (parse_box (fun n -> PpHVB n) (i+3))
-		(* Parse " [v .. ",  *)
-	    | 'v' ->
-		    parse_box (fun n -> PpVB n) (i+2)
-		(* Parse " [ .. ",  *)
-	    | ' ' | '\'' ->
-		parse_box (fun n -> PpHOVB n) (i+1)
-	    | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format."
-	  else error "\"v\", \"hv\" or \" \" expected after \"[\" in format."
-      (* Parse "]"  *)
-      | ']' ->
-	  ([] :: parse_token (close_quotation (i+1)))
-      (* Parse a non formatting token *)
-      | c ->
-	  let n = nonspaces true 0 i in
-	  push_token (UnpTerminal (String.sub str (i-1) (n+2)))
-	    (parse_token (close_quotation (i+n))))
-    else
-      if Int.equal n 0 then []
-      else error "Ending spaces non part of a format annotation."
-  and parse_box box i =
-    let n = spaces 0 i in
-    close_box i (box n) (parse_token (close_quotation (i+n)))
-  and parse_token i =
-    let n = spaces 0 i in
-    let i = i+n in
-    if i < l then match str.[i] with
-      (* Parse a ' *)
-      |	'\'' when i+1 >= String.length str || str.[i+1] == ' ' ->
-	  push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1)))
-      (* Parse the beginning of a quoted expression *)
-      |	'\'' ->
-          parse_quoted (n-1) (i+1)
-      (* Otherwise *)
-      | _ ->
-          push_white (n-1) (parse_non_format i)
-    else push_white n [[]]
-  in
-  try
-    if not (String.is_empty str) then match parse_token 0 with
-      | [l] -> l
-      | _ -> error "Box closed without being opened in format."
-    else
-      error "Empty format."
-  with reraise ->
-    let (e, info) = CErrors.push reraise in
-    let info = Loc.add_loc info loc in
-    iraise (e, info)
-
-(***********************)
-(* Analyzing notations *)
-
-type symbol_token = WhiteSpace of int | String of string
-
-let split_notation_string str =
-  let push_token beg i l =
-    if Int.equal beg i then l else
-      let s = String.sub str beg (i - beg) in
-      String s :: l
-  in
-  let push_whitespace beg i l =
-    if Int.equal beg i then l else WhiteSpace (i-beg) :: l
-  in
-  let rec loop beg i =
-    if i < String.length str then
-      if str.[i] == ' ' then
-	push_token beg i (loop_on_whitespace (i+1) (i+1))
-      else
-	loop beg (i+1)
-    else
-      push_token beg i []
-  and loop_on_whitespace beg i =
-    if i < String.length str then
-      if str.[i] != ' ' then
-	push_whitespace beg i (loop i (i+1))
-      else
-	loop_on_whitespace beg (i+1)
-    else
-      push_whitespace beg i []
-  in
-  loop 0 0
-
-(* Interpret notations with a recursive component *)
-
-let out_nt = function NonTerminal x -> x | _ -> assert false
-
-let msg_expected_form_of_recursive_notation =
-  "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"."
-
-let rec find_pattern nt xl = function
-  | Break n as x :: l, Break n' :: l' when Int.equal n n' ->
-      find_pattern nt (x::xl) (l,l')
-  | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' ->
-      find_pattern nt (x::xl) (l,l')
-  | [], NonTerminal x' :: l' ->
-      (out_nt nt,x',List.rev xl),l'
-  | _, Break s :: _ | Break s :: _, _ ->
-      error ("A break occurs on one side of \"..\" but not on the other side.")
-  | _, Terminal s :: _ | Terminal s :: _, _ ->
-      errorlabstrm "Metasyntax.find_pattern"
-        (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.")
-  | _, [] ->
-      error msg_expected_form_of_recursive_notation
-  | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
-      anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right")
-
-let rec interp_list_parser hd = function
-  | [] -> [], List.rev hd
-  | NonTerminal id :: tl when Id.equal id ldots_var ->
-      if List.is_empty hd then error msg_expected_form_of_recursive_notation;
-      let hd = List.rev hd in
-      let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in
-      let xyl,tl'' = interp_list_parser [] tl' in
-      (* We remember each pair of variable denoting a recursive part to *)
-      (* remove the second copy of it afterwards *)
-      (x,y)::xyl, SProdList (x,sl) :: tl''
-  | (Terminal _ | Break _) as s :: tl ->
-      if List.is_empty hd then
-        let yl,tl' = interp_list_parser [] tl in
-        yl, s :: tl'
-      else
-        interp_list_parser (s::hd) tl
-  | NonTerminal _ as x :: tl ->
-      let xyl,tl' = interp_list_parser [x] tl in
-      xyl, List.rev_append hd tl'
-  | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser")
-
-
-(* Find non-terminal tokens of notation *)
-
-(* To protect alphabetic tokens and quotes from being seen as variables *)
-let quote_notation_token x =
-  let n = String.length x in
-  let norm = CLexer.is_ident x in
-  if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'"
-  else x
-
-let rec raw_analyze_notation_tokens = function
-  | []    -> []
-  | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl
-  | String "_" :: _ -> error "_ must be quoted."
-  | String x :: sl when CLexer.is_ident x ->
-      NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl
-  | String s :: sl ->
-      Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl
-  | WhiteSpace n :: sl ->
-      Break n :: raw_analyze_notation_tokens sl
-
-let is_numeral symbs =
-  match List.filter (function Break _ -> false | _ -> true) symbs with
-  | ([Terminal "-"; Terminal x] | [Terminal x]) ->
-      (try let _ = Bigint.of_string x in true with Failure _ -> false)
-  | _ ->
-      false
-
-let rec get_notation_vars = function
-  | [] -> []
-  | NonTerminal id :: sl ->
-      let vars = get_notation_vars sl in
-      if Id.equal id ldots_var then vars else
-	if Id.List.mem id vars then
-	  errorlabstrm "Metasyntax.get_notation_vars"
-            (str "Variable " ++ pr_id id ++ str " occurs more than once.")
-	else
-          id::vars
-  | (Terminal _ | Break _) :: sl -> get_notation_vars sl
-  | SProdList _ :: _ -> assert false
-
-let analyze_notation_tokens l =
-  let l = raw_analyze_notation_tokens l in
-  let vars = get_notation_vars l in
-  let recvars,l = interp_list_parser [] l in
-  recvars, List.subtract Id.equal vars (List.map snd recvars), l
-
-let error_not_same_scope x y =
-  errorlabstrm "Metasyntax.error_not_name_scope"
-    (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.")
-
-(**********************************************************************)
-(* Build pretty-printing rules                                        *)
-
-let prec_assoc = function
-  | RightA -> (L,E)
-  | LeftA -> (E,L)
-  | NonA -> (L,L)
-
-let precedence_of_entry_type from = function
-  | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
-  | ETConstr (NumLevel n,BorderProd (b,Some a)) ->
-      n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp
-  | ETConstr (NumLevel n,InternalProd) -> n, Prec n
-  | ETConstr (NextLevel,_) -> from, L
-  | _ -> 0, E (* ?? *)
-
-(* Some breaking examples *)
-(* "x = y" : "x /1 = y" (breaks before any symbol) *)
-(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*)
-(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *)
-(* "x y" : "x spc y" *)
-(* "{ x } + { y }" : "{ x } / + { y }" *)
-(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *)
-
-let starts_with_left_bracket s =
-  let l = String.length s in not (Int.equal l 0) &&
-  (s.[0] == '{' || s.[0] == '[' || s.[0] == '(')
-
-let ends_with_right_bracket s =
-  let l = String.length s in not (Int.equal l 0) &&
-  (s.[l-1] == '}' || s.[l-1] == ']' || s.[l-1] == ')')
-
-let is_left_bracket s =
-  starts_with_left_bracket s && not (ends_with_right_bracket s)
-
-let is_right_bracket s =
-  not (starts_with_left_bracket s) && ends_with_right_bracket s
-
-let is_comma s =
-  let l = String.length s in not (Int.equal l 0) &&
-  (s.[0] == ',' || s.[0] == ';')
-
-let is_operator s =
-  let l = String.length s in not (Int.equal l 0) &&
-  (s.[0] == '+' || s.[0] == '*' || s.[0] == '=' ||
-   s.[0] == '-' || s.[0] == '/' || s.[0] == '<' || s.[0] == '>' ||
-   s.[0] == '@' || s.[0] == '\\' || s.[0] == '&' || s.[0] == '~' || s.[0] == '$')
-
-let is_non_terminal = function
-  | NonTerminal _ | SProdList _ -> true
-  | _ -> false
-
-let is_next_non_terminal = function
-| [] -> false
-| pr :: _ -> is_non_terminal pr
-
-let is_next_terminal = function Terminal _ :: _ -> true | _ -> false
-
-let is_next_break = function Break _ :: _ -> true | _ -> false
-
-let add_break n l = UnpCut (PpBrk(n,0)) :: l
-
-let add_break_if_none n = function
-  | ((UnpCut (PpBrk _) :: _) | []) as l -> l
-  | l -> UnpCut (PpBrk(n,0)) :: l
-
-let check_open_binder isopen sl m =
-  let pr_token = function
-  | Terminal s -> str s
-  | Break n -> str "␣"
-  | _ -> assert false
-  in
-  if isopen && not (List.is_empty sl) then
-    errorlabstrm "" (str "as " ++ pr_id m ++
-      str " is a non-closed binder, no such \"" ++
-      prlist_with_sep spc pr_token sl
-      ++ strbrk "\" is allowed to occur.")
-
-(* Heuristics for building default printing rules *)
-
-let index_id id l = List.index Id.equal id l
-
-let make_hunks etyps symbols from =
-  let vars,typs = List.split etyps in
-  let rec make = function
-    | NonTerminal m :: prods ->
-	let i = index_id m vars in
-	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
-	let u = UnpMetaVar (i,prec) in
-	if is_next_non_terminal prods then
-	  u :: add_break_if_none 1 (make prods)
-	else
-	  u :: make_with_space prods
-    | Terminal s :: prods when List.exists is_non_terminal prods ->
-        if (is_comma s || is_operator s) then
-          (* Always a breakable space after comma or separator *)
-	  UnpTerminal s :: add_break_if_none 1 (make prods)
-	else if is_right_bracket s && is_next_terminal prods then
-          (* Always no space after right bracked, but possibly a break *)
-	  UnpTerminal s :: add_break_if_none 0 (make prods)
-        else if is_left_bracket s  && is_next_non_terminal prods then
-	  UnpTerminal s :: make prods
-	else if not (is_next_break prods) then
-          (* Add rigid space, no break, unless user asked for something *)
-          UnpTerminal (s^" ") :: make prods
-        else
-          (* Rely on user spaces *)
-          UnpTerminal s :: make prods
-
-    | Terminal s :: prods ->
-        (* Separate but do not cut a trailing sequence of terminal *)
-        (match prods with
-        | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods
-        | _ -> UnpTerminal s :: make prods)
-
-    | Break n :: prods ->
-	add_break n (make prods)
-
-    | SProdList (m,sl) :: prods ->
-	let i = index_id m vars in
-	let typ = List.nth typs (i-1) in
-	let _,prec = precedence_of_entry_type from typ in
-        let sl' =
-          (* If no separator: add a break *)
-	  if List.is_empty sl then add_break 1 []
-          (* We add NonTerminal for simulation but remove it afterwards *)
-	  else snd (List.sep_last (make (sl@[NonTerminal m]))) in
-	let hunk = match typ with
-	  | ETConstr _ -> UnpListMetaVar (i,prec,sl')
-	  | ETBinder isopen ->
-	      check_open_binder isopen sl m;
-	      UnpBinderListMetaVar (i,isopen,sl')
-	  | _ -> assert false in
-	hunk :: make_with_space prods
-
-    | [] -> []
-
-  and make_with_space prods =
-    match prods with
-    | Terminal s' :: prods'->
-        if is_operator s' then
-          (* A rigid space before operator and a breakable after *)
-          UnpTerminal (" "^s') :: add_break_if_none 1 (make prods')
-        else if is_comma s' then
-          (* No space whatsoever before comma *)
-          make prods
-        else if is_right_bracket s' then
-          make prods
-        else
-          (* A breakable space between any other two terminals *)
-          add_break_if_none 1 (make prods)
-    | (NonTerminal _ | SProdList _) :: _ ->
-        (* A breakable space before a non-terminal *)
-        add_break_if_none 1 (make prods)
-    | Break _ :: _ ->
-        (* Rely on user wish *)
-        make prods
-    | [] -> []
-
-  in make symbols
-
-(* Build default printing rules from explicit format *)
-
-let error_format () = error "The format does not match the notation."
-
-let rec split_format_at_ldots hd = function
-  | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt
-  | u :: fmt ->
-      check_no_ldots_in_box u;
-      split_format_at_ldots (u::hd) fmt
-  | [] -> raise Exit
-
-and check_no_ldots_in_box = function
-  | UnpBox (_,fmt) ->
-      (try
-        let _ = split_format_at_ldots [] fmt in
-        error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")
-      with Exit -> ())
-  | _ -> ()
-
-let skip_var_in_recursive_format = function
-  | UnpTerminal _ :: sl (* skip first var *) ->
-      (* To do, though not so important: check that the names match
-         the names in the notation *)
-      sl
-  | _ -> error_format ()
-
-let read_recursive_format sl fmt =
-  let get_head fmt =
-    let sl = skip_var_in_recursive_format fmt in
-    try split_format_at_ldots [] sl with Exit -> error_format () in
-  let rec get_tail = function
-    | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
-    | [], tail -> skip_var_in_recursive_format tail
-    | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in
-  let slfmt, fmt = get_head fmt in
-  slfmt, get_tail (slfmt, fmt)
-
-let hunks_of_format (from,(vars,typs)) symfmt =
-  let rec aux = function
-  | symbs, (UnpTerminal s' as u) :: fmt
-      when String.equal s' (String.make (String.length s') ' ') ->
-      let symbs, l = aux (symbs,fmt) in symbs, u :: l
-  | Terminal s :: symbs, (UnpTerminal s') :: fmt
-      when String.equal s (String.drop_simple_quotes s') ->
-      let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
-  | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') ->
-      let i = index_id s vars in
-      let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
-      let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
-  | symbs, UnpBox (a,b) :: fmt ->
-      let symbs', b' = aux (symbs,b) in
-      let symbs', l = aux (symbs',fmt) in
-      symbs', UnpBox (a,b') :: l
-  | symbs, (UnpCut _ as u) :: fmt ->
-      let symbs, l = aux (symbs,fmt) in symbs, u :: l
-  | SProdList (m,sl) :: symbs, fmt ->
-      let i = index_id m vars in
-      let typ = List.nth typs (i-1) in
-      let _,prec = precedence_of_entry_type from typ in
-      let slfmt,fmt = read_recursive_format sl fmt in
-      let sl, slfmt = aux (sl,slfmt) in
-      if not (List.is_empty sl) then error_format ();
-      let symbs, l = aux (symbs,fmt) in
-      let hunk = match typ with
-	| ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
-	| ETBinder isopen ->
-	    check_open_binder isopen sl m;
-	    UnpBinderListMetaVar (i,isopen,slfmt)
-	| _ -> assert false in
-      symbs, hunk :: l
-  | symbs, [] -> symbs, []
-  | _, _ -> error_format ()
-  in
-  match aux symfmt with
-  | [], l -> l
-  | _ -> error_format ()
-
-(**********************************************************************)
-(* Build parsing rules                                                *)
-
-let assoc_of_type n (_,typ) = precedence_of_entry_type n typ
-
-let is_not_small_constr = function
-    ETConstr _ -> true
-  | ETOther("constr","binder_constr") -> true
-  | _ -> false
-
-let rec define_keywords_aux = function
-  | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l
-      when is_not_small_constr e ->
-      Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
-      CLexer.add_keyword k;
-      n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
-  | n :: l -> n :: define_keywords_aux l
-  | [] -> []
-
-  (* Ensure that IDENT articulation terminal symbols are keywords *)
-let define_keywords = function
-  | GramConstrTerminal(IDENT k)::l ->
-      Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
-      CLexer.add_keyword k;
-      GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
-  | l -> define_keywords_aux l
-
-let distribute a ll = List.map (fun l -> a @ l) ll
-
-  (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep)
-     as many times as expected in [n] argument *)
-let rec expand_list_rule typ tkl x n i hds ll =
-  if Int.equal i n then
-    let hds =
-      GramConstrListMark (n,true) :: hds
-      @	[GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in
-    distribute hds ll
-  else
-    let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in
-    let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in
-    let tks = List.map (fun x -> GramConstrTerminal x) tkl in
-    distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @
-      expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll
-
-let make_production etyps symbols =
-  let prod =
-    List.fold_right
-      (fun t ll -> match t with
-        | NonTerminal m ->
-	    let typ = List.assoc m etyps in
-	    distribute [GramConstrNonTerminal (typ, Some m)] ll
-        | Terminal s ->
-	    distribute [GramConstrTerminal (CLexer.terminal s)] ll
-        | Break _ ->
-            ll
-        | SProdList (x,sl) ->
-            let tkl = List.flatten
-              (List.map (function Terminal s -> [CLexer.terminal s]
-                | Break _ -> []
-                | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in
-	    match List.assoc x etyps with
-            | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll
-            | ETBinder o ->
-		distribute
-                  [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll
-            | _ ->
-                error "Components of recursive patterns in notation must be terms or binders.")
-      symbols [[]] in
-  List.map define_keywords prod
-
-let rec find_symbols c_current c_next c_last = function
-  | [] -> []
-  | NonTerminal id :: sl ->
-      let prec = if not (List.is_empty sl) then c_current else c_last in
-      (id, prec) :: (find_symbols c_next c_next c_last sl)
-  | Terminal s :: sl -> find_symbols c_next c_next c_last sl
-  | Break n :: sl -> find_symbols c_current c_next c_last sl
-  | SProdList (x,_) :: sl' ->
-      (x,c_next)::(find_symbols c_next c_next c_last sl')
-
-let border = function
-  | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a
-  | _ -> None
-
-let recompute_assoc typs =
-  match border typs, border (List.rev typs) with
-    | Some LeftA, Some RightA -> assert false
-    | Some LeftA, _ -> Some LeftA
-    | _, Some RightA -> Some RightA
-    | _ -> None
-
-(**************************************************************************)
-(* Registration of syntax extensions (parsing/printing, no interpretation)*)
-
-let pr_arg_level from = function
-  | (n,L) when Int.equal n from -> str "at next level"
-  | (n,E) -> str "at level " ++ int n
-  | (n,L) -> str "at level below " ++ int n
-  | (n,Prec m) when Int.equal m n -> str "at level " ++ int n
-  | (n,_) -> str "Unknown level"
-
-let pr_level ntn (from,args) =
-  str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
-  prlist_with_sep pr_comma (pr_arg_level from) args
-
-let error_incompatible_level ntn oldprec prec =
-  errorlabstrm ""
-    (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++
-    pr_level ntn oldprec ++
-    spc() ++ str "while it is now required to be" ++ spc() ++
-    pr_level ntn prec ++ str ".")
-
-type syntax_extension = {
-  synext_level : Notation.level;
-  synext_notation : notation;
-  synext_notgram : notation_grammar;
-  synext_unparsing : unparsing list;
-  synext_extra : (string * string) list;
-  synext_compat : Flags.compat_version option;
-}
-
-let is_active_compat = function
-| None -> true
-| Some v -> 0 <= Flags.version_compare v !Flags.compat_version
-
-type syntax_extension_obj = locality_flag * syntax_extension list
-
-let cache_one_syntax_extension se =
-  let ntn = se.synext_notation in
-  let prec = se.synext_level in
-  let onlyprint = se.synext_notgram.notgram_onlyprinting in
-  try
-    let oldprec = Notation.level_of_notation ntn in
-    if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec
-  with Not_found ->
-    if is_active_compat se.synext_compat then begin
-      (* Reserve the notation level *)
-      Notation.declare_notation_level ntn prec;
-      (* Declare the parsing rule *)
-      if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram;
-      (* Declare the notation rule *)
-      Notation.declare_notation_rule ntn
-        ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram
-    end
-
-let cache_syntax_extension (_, (_, sy)) =
-  List.iter cache_one_syntax_extension sy
-
-let subst_parsing_rule subst x = x
-
-let subst_printing_rule subst x = x
-
-let subst_syntax_extension (subst, (local, sy)) =
-  let map sy = { sy with
-    synext_notgram = subst_parsing_rule subst sy.synext_notgram;
-    synext_unparsing = subst_printing_rule subst sy.synext_unparsing;
-  } in
-  (local, List.map map sy)
-
-let classify_syntax_definition (local, _ as o) =
-  if local then Dispose else Substitute o
-
-let inSyntaxExtension : syntax_extension_obj -> obj =
-  declare_object {(default_object "SYNTAX-EXTENSION") with
-       open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o);
-       cache_function = cache_syntax_extension;
-       subst_function = subst_syntax_extension;
-       classify_function = classify_syntax_definition}
-
-(**************************************************************************)
-(* Precedences                                                            *)
-
-(* Interpreting user-provided modifiers *)
-
-let interp_modifiers modl =
-  let onlyparsing = ref false in
-  let onlyprinting = ref false in
-  let compat = ref None in
-  let rec interp assoc level etyps format extra = function
-    | [] ->
-	(assoc,level,etyps,!onlyparsing,!onlyprinting,!compat,format,extra)
-    | SetEntryType (s,typ) :: l ->
-	let id = Id.of_string s in
-	if Id.List.mem_assoc id etyps then
-	  errorlabstrm "Metasyntax.interp_modifiers"
-            (str s ++ str " is already assigned to an entry or constr level.");
-	interp assoc level ((id,typ)::etyps) format extra l
-    | SetItemLevel ([],n) :: l ->
-	interp assoc level etyps format extra l
-    | SetItemLevel (s::idl,n) :: l ->
-	let id = Id.of_string s in
-	if Id.List.mem_assoc id etyps then
-	  errorlabstrm "Metasyntax.interp_modifiers"
-            (str s ++ str " is already assigned to an entry or constr level.");
-	let typ = ETConstr (n,()) in
-	interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l)
-    | SetLevel n :: l ->
-	if not (Option.is_empty level) then error "A level is given more than once.";
-	interp assoc (Some n) etyps format extra l
-    | SetAssoc a :: l ->
-	if not (Option.is_empty assoc) then error"An associativity is given more than once.";
-	interp (Some a) level etyps format extra l
-    | SetOnlyParsing :: l ->
-	onlyparsing := true;
-	interp assoc level etyps format extra l
-    | SetOnlyPrinting :: l ->
-	onlyprinting := true;
-	interp assoc level etyps format extra l
-    | SetCompatVersion v :: l ->
-        compat := Some v;
-	interp assoc level etyps format extra l
-    | SetFormat ("text",s) :: l ->
-	if not (Option.is_empty format) then error "A format is given more than once.";
-	interp assoc level etyps (Some s) extra l
-    | SetFormat (k,(_,s)) :: l ->
-	interp assoc level etyps format ((k,s) :: extra) l
-  in interp None None [] None [] modl
-
-let check_infix_modifiers modifiers =
-  let (_, _, t, _, _, _, _, _) = interp_modifiers modifiers in
-  if not (List.is_empty t) then
-    error "Explicit entry level or type unexpected in infix notation."
-
-let check_useless_entry_types recvars mainvars etyps =
-  let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in
-  match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with
-  | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types"
-                  (pr_id x ++ str " is unbound in the notation.")
-  | _ -> ()
-
-let not_a_syntax_modifier = function
-| SetOnlyParsing -> true
-| SetOnlyPrinting -> true
-| SetCompatVersion _ -> true
-| _ -> false
-
-let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods
-
-let is_only_parsing mods =
-  let test = function SetOnlyParsing -> true | _ -> false in
-  List.exists test mods
-
-let is_only_printing mods =
-  let test = function SetOnlyPrinting -> true | _ -> false in
-  List.exists test mods
-
-let get_compat_version mods =
-  let test = function SetCompatVersion v -> Some v | _ -> None in
-  try Some (List.find_map test mods) with Not_found -> None
-
-(* Compute precedences from modifiers (or find default ones) *)
-
-let set_entry_type etyps (x,typ) =
-  let typ = try
-    match List.assoc x etyps, typ with
-      | ETConstr (n,()), (_,BorderProd (left,_)) ->
-          ETConstr (n,BorderProd (left,None))
-      | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
-      | (ETPattern | ETName | ETBigint | ETOther _ |
-	 ETReference | ETBinder _ as t), _ -> t
-      | (ETBinderList _ |ETConstrList _), _ -> assert false
-    with Not_found -> ETConstr typ
-  in (x,typ)
-
-let join_auxiliary_recursive_types recvars etyps =
-  List.fold_right (fun (x,y) typs ->
-    let xtyp = try Some (List.assoc x etyps) with Not_found -> None in
-    let ytyp = try Some (List.assoc y etyps) with Not_found -> None in
-    match xtyp,ytyp with
-    | None, None -> typs
-    | Some _, None -> typs
-    | None, Some ytyp -> (x,ytyp)::typs
-    | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *)
-    | Some xtyp, Some ytyp ->
-	errorlabstrm ""
-	  (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++
-	   strbrk ", both ends have incompatible types."))
-    recvars etyps
-
-let internalization_type_of_entry_type = function
-  | ETConstr _ -> NtnInternTypeConstr
-  | ETBigint | ETReference -> NtnInternTypeConstr
-  | ETBinder _ -> NtnInternTypeBinder
-  | ETName -> NtnInternTypeIdent
-  | ETPattern | ETOther _ -> error "Not supported."
-  | ETBinderList _ | ETConstrList _ -> assert false
-
-let set_internalization_type typs =
-  List.map (fun (_, e) -> internalization_type_of_entry_type e) typs
-
-let make_internalization_vars recvars mainvars typs =
-  let maintyps = List.combine mainvars typs in
-  let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in
-  maintyps @ extratyps
-
-let make_interpretation_type isrec isonlybinding = function
-  | NtnInternTypeConstr when isrec -> NtnTypeConstrList
-  | NtnInternTypeConstr | NtnInternTypeIdent ->
-     if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr
-  | NtnInternTypeBinder when isrec -> NtnTypeBinderList
-   | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders."
-
-let make_interpretation_vars recvars allvars =
-  let eq_subscope (sc1, l1) (sc2, l2) =
-    Option.equal String.equal sc1 sc2 &&
-    List.equal String.equal l1 l2
-  in
-  let check (x, y) =
-    let (_,scope1, _) = Id.Map.find x allvars in
-    let (_,scope2, _) = Id.Map.find y allvars in
-    if not (eq_subscope scope1 scope2) then error_not_same_scope x y
-  in
-  let () = List.iter check recvars in
-  let useless_recvars = List.map snd recvars in
-  let mainvars =
-    Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in
-  Id.Map.mapi (fun x (isonlybinding, sc, typ) ->
-    (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars
-
-let check_rule_productivity l =
-  if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then
-    error "A notation must include at least one symbol.";
-  if (match l with SProdList _ :: _ -> true | _ -> false) then
-    error "A recursive notation must start with at least one symbol."
-
-let warn_notation_bound_to_variable =
-  CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing"
-         (fun () ->
-          strbrk "This notation will not be used for printing as it is bound to a single variable.")
-
-let warn_non_reversible_notation =
-  CWarnings.create ~name:"non-reversible-notation" ~category:"parsing"
-         (fun () ->
-          strbrk "This notation will not be used for printing as it is not reversible.")
-
-let is_not_printable onlyparse nonreversible = function
-| NVar _ ->
-  if not onlyparse then warn_notation_bound_to_variable ();
-  true
-| _ ->
-   if not onlyparse && nonreversible then
-     (warn_non_reversible_notation (); true)
-  else onlyparse
-
-let find_precedence lev etyps symbols =
-  let first_symbol =
-    let rec aux = function
-      | Break _ :: t -> aux t
-      | h :: t -> h
-      | [] -> assert false (* rule is known to be productive *) in
-    aux symbols in
-  let last_is_terminal () =
-    let rec aux b = function
-      | Break _ :: t -> aux b t
-      | Terminal _ :: t -> aux true t
-      | _ :: t -> aux false t
-      | [] -> b in
-    aux false symbols in
-  match first_symbol with
-  | NonTerminal x ->
-      (try match List.assoc x etyps with
-	| ETConstr _ ->
-	    error "The level of the leftmost non-terminal cannot be changed."
-	| ETName | ETBigint | ETReference ->
-            begin match lev with
-            | None ->
-	      ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0)
-            | Some 0 ->
-              ([],0)
-            | _ ->
-	      error "A notation starting with an atomic expression must be at level 0."
-            end
-	| ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *)
-	    if Option.is_empty lev then
-	      error "Need an explicit level."
-	    else [],Option.get lev
-        | ETConstrList _ | ETBinderList _ ->
-	    assert false (* internally used in grammar only *)
-      with Not_found ->
-	if Option.is_empty lev then
-	  error "A left-recursive notation must have an explicit level."
-	else [],Option.get lev)
-  | Terminal _ when last_is_terminal () ->
-      if Option.is_empty lev then
-	([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0)
-      else [],Option.get lev
-  | _ ->
-      if Option.is_empty lev then error "Cannot determine the level.";
-      [],Option.get lev
-
-let check_curly_brackets_notation_exists () =
-  try let _ = Notation.level_of_notation "{ _ }" in ()
-  with Not_found ->
-    error "Notations involving patterns of the form \"{ _ }\" are treated \n\
-specially and require that the notation \"{ _ }\" is already reserved."
-
-let warn_skip_spaces_curly =
-  CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
-      (fun () ->strbrk "Skipping spaces inside curly brackets")
-
-(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
-let remove_curly_brackets l =
-  let rec skip_break acc = function
-    | Break _ as br :: l -> skip_break (br::acc) l
-    | l -> List.rev acc, l in
-  let rec aux deb = function
-  | [] -> []
-  | Terminal "{" as t1 :: l ->
-      let br,next = skip_break [] l in
-      (match next with
-        | NonTerminal _ as x :: l' as l0 ->
-            let br',next' = skip_break [] l' in
-            (match next' with
-              | Terminal "}" as t2 :: l'' as l1 ->
-                 if not (List.equal Notation.symbol_eq l l0) ||
-		      not (List.equal Notation.symbol_eq l' l1) then
-		  warn_skip_spaces_curly ();
-		  if deb && List.is_empty l'' then [t1;x;t2] else begin
-                    check_curly_brackets_notation_exists ();
-                    x :: aux false l''
-                  end
-              | l1 -> t1 :: br @ x :: br' @ aux false l1)
-        | l0 -> t1 :: aux false l0)
-  | x :: l -> x :: aux false l
-  in aux true l
-
-let compute_syntax_data df modifiers =
-  let (assoc,n,etyps,onlyparse,onlyprint,compat,fmt,extra) = interp_modifiers modifiers in
-  let assoc = match assoc with None -> (* default *) Some NonA | a -> a in
-  let toks = split_notation_string df in
-  let (recvars,mainvars,symbols) = analyze_notation_tokens toks in
-  let _ = check_useless_entry_types recvars mainvars etyps in
-  let ntn_for_interp = make_notation_key symbols in
-  let symbols' = remove_curly_brackets symbols in
-  let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in
-  let ntn_for_grammar = make_notation_key symbols' in
-  check_rule_productivity symbols';
-  let msgs,n = find_precedence n etyps symbols' in
-  let innerlevel = NumLevel 200 in
-  let typs =
-    find_symbols
-      (NumLevel n,BorderProd(Left,assoc))
-      (innerlevel,InternalProd)
-      (NumLevel n,BorderProd(Right,assoc))
-      symbols' in
-  (* To globalize... *)
-  let etyps = join_auxiliary_recursive_types recvars etyps in
-  let sy_typs = List.map (set_entry_type etyps) typs in
-  let prec = (n,List.map (assoc_of_type n) sy_typs) in
-  let i_typs = set_internalization_type sy_typs in
-  let sy_data = (n,sy_typs,symbols',fmt) in
-  let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in
-  let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
-  let i_data = (onlyparse,onlyprint,compat,recvars,mainvars,(ntn_for_interp,df')) in
-  (* Return relevant data for interpretation and for parsing/printing *)
-  (msgs,i_data,i_typs,sy_fulldata,extra)
-
-let compute_pure_syntax_data df mods =
-  let (msgs,(onlyparse,onlyprint,_,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in
-  let msgs =
-    if onlyparse then
-      (Feedback.msg_warning ?loc:None,
-      strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs
-    else msgs in
-  msgs, sy_data, extra, onlyprint
-
-(**********************************************************************)
-(* Registration of notations interpretation                            *)
-
-type notation_obj = {
-  notobj_local : bool;
-  notobj_scope : scope_name option;
-  notobj_interp : interpretation;
-  notobj_onlyparse : bool;
-  notobj_onlyprint : bool;
-  notobj_compat : Flags.compat_version option;
-  notobj_notation : notation * notation_location;
-}
-
-let load_notation _ (_, nobj) =
-  Option.iter Notation.declare_scope nobj.notobj_scope
-
-let open_notation i (_, nobj) =
-  let scope = nobj.notobj_scope in
-  let (ntn, df) = nobj.notobj_notation in
-  let pat = nobj.notobj_interp in
-  let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in
-  let active = is_active_compat nobj.notobj_compat in
-  if Int.equal i 1 && fresh && active then begin
-    (* Declare the interpretation *)
-    let onlyprint = nobj.notobj_onlyprint  in
-    let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in
-    (* Declare the uninterpretation *)
-    if not nobj.notobj_onlyparse then
-      Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat
-  end
-
-let cache_notation o =
-  load_notation 1 o;
-  open_notation 1 o
-
-let subst_notation (subst, nobj) =
-  { nobj with notobj_interp = subst_interpretation subst nobj.notobj_interp; }
-
-let classify_notation nobj =
-  if nobj.notobj_local then Dispose else Substitute nobj
-
-let inNotation : notation_obj -> obj =
-  declare_object {(default_object "NOTATION") with
-       open_function = open_notation;
-       cache_function = cache_notation;
-       subst_function = subst_notation;
-       load_function = load_notation;
-       classify_function = classify_notation}
-
-(**********************************************************************)
-
-let with_lib_stk_protection f x =
-  let fs = Lib.freeze `No in
-  try let a = f x in Lib.unfreeze fs; a
-  with reraise ->
-    let reraise = CErrors.push reraise in
-    let () = Lib.unfreeze fs in
-    iraise reraise
-
-let with_syntax_protection f x =
-  with_lib_stk_protection
-    (with_grammar_rule_protection
-       (with_notation_protection f)) x
-
-(**********************************************************************)
-(* Recovering existing syntax                                         *)
-
-let contract_notation ntn =
-  if String.equal ntn "{ _ }" then ntn else
-  let rec aux ntn i =
-    if i <= String.length ntn - 5 then
-      let ntn' =
-        if String.is_sub "{ _ }" ntn i &&
-           (i = 0 || ntn.[i-1] = ' ') &&
-           (i = String.length ntn - 5 || ntn.[i+5] = ' ')
-        then
-          String.sub ntn 0 i ^ "_" ^
-          String.sub ntn (i+5) (String.length ntn -i-5)
-        else ntn in
-      aux ntn' (i+1)
-    else ntn in
-  aux ntn 0
-
-exception NoSyntaxRule
-
-let recover_syntax ntn =
-  try
-    let prec = Notation.level_of_notation ntn in
-    let pp_rule,_ = Notation.find_notation_printing_rule ntn in
-    let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in
-    let pa_rule = Notation.find_notation_parsing_rules ntn in
-    { synext_level = prec;
-      synext_notation = ntn;
-      synext_notgram = pa_rule;
-      synext_unparsing = pp_rule;
-      synext_extra = pp_extra_rules;
-      synext_compat = None;
-    }
-  with Not_found ->
-    raise NoSyntaxRule
-
-let recover_squash_syntax sy =
-  let sq = recover_syntax "{ _ }" in
-  [sy; sq]
-
-let recover_notation_syntax rawntn =
-  let ntn = contract_notation rawntn in
-  let sy = recover_syntax ntn in
-  let need_squash = not (String.equal ntn rawntn) in
-  let rules = if need_squash then recover_squash_syntax sy else [sy] in
-  sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting
-
-(**********************************************************************)
-(* Main entry point for building parsing and printing rules           *)
-
-let make_pa_rule i_typs (n,typs,symbols,_) ntn onlyprint =
-  let assoc = recompute_assoc typs in
-  let prod = make_production typs symbols in
-  { notgram_level = n;
-    notgram_assoc = assoc;
-    notgram_notation = ntn;
-    notgram_prods = prod;
-    notgram_typs = i_typs;
-    notgram_onlyprinting = onlyprint;
-  }
-
-let make_pp_rule (n,typs,symbols,fmt) =
-  match fmt with
-  | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
-  | Some fmt -> hunks_of_format (n, List.split typs) (symbols, parse_format fmt)
-
-let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint compat =
-  let pa_rule = make_pa_rule i_typs sy_data ntn onlyprint in
-  let pp_rule = make_pp_rule sy_data in
-  let sy = {
-    synext_level = prec;
-    synext_notation = ntn;
-    synext_notgram = pa_rule;
-    synext_unparsing = pp_rule;
-    synext_extra = extra;
-    synext_compat = compat;
-  } in
-  (* By construction, the rule for "{ _ }" is declared, but we need to
-     redeclare it because the file where it is declared needs not be open
-     when the current file opens (especially in presence of -nois) *)
-  if need_squash then recover_squash_syntax sy else [sy]
-
-(**********************************************************************)
-(* Main functions about notations                                     *)
-
-let to_map l =
-  let fold accu (x, v) = Id.Map.add x v accu in
-  List.fold_left fold Id.Map.empty l
-
-let add_notation_in_scope local df c mods scope =
-  let (msgs,i_data,i_typs,sy_data,extra) = compute_syntax_data df mods in
-  (* Prepare the interpretation *)
-  let (onlyparse, onlyprint, compat, recvars,mainvars, df') = i_data in
-  (* Prepare the parsing and printing rules *)
-  let sy_rules = make_syntax_rules sy_data extra onlyprint compat in
-  let i_vars = make_internalization_vars recvars mainvars i_typs in
-  let nenv = {
-    ninterp_var_type = to_map i_vars;
-    ninterp_rec_vars = to_map recvars;
-  } in
-  let (acvars, ac, reversible) = interp_notation_constr nenv c in
-  let interp = make_interpretation_vars recvars acvars in
-  let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
-  let onlyparse = is_not_printable onlyparse (not reversible) ac in
-  let notation = {
-    notobj_local = local;
-    notobj_scope = scope;
-    notobj_interp = (List.map_filter map i_vars, ac);
-    (** Order is important here! *)
-    notobj_onlyparse = onlyparse;
-    notobj_onlyprint = onlyprint;
-    notobj_compat = compat;
-    notobj_notation = df';
-  } in
-  (* Ready to change the global state *)
-  Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
-  Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules));
-  Lib.add_anonymous_leaf (inNotation notation);
-  df'
-
-let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
-  let dfs = split_notation_string df in
-  let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in
-  (* Recover types of variables and pa/pp rules; redeclare them if needed *)
-  let i_typs, onlyprint = if not (is_numeral symbs) then begin
-    let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in
-    let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in
-    (** If the only printing flag has been explicitly requested, put it back *)
-    let onlyprint = onlyprint || onlyprint' in
-    i_typs, onlyprint
-  end else [], false in
-  (* Declare interpretation *)
-  let path = (Lib.library_dp(),Lib.current_dirpath true) in
-  let df' = (make_notation_key symbs,(path,df)) in
-  let i_vars = make_internalization_vars recvars mainvars i_typs in
-  let nenv = {
-    ninterp_var_type = to_map i_vars;
-    ninterp_rec_vars = to_map recvars;
-  } in
-  let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in
-  let interp = make_interpretation_vars recvars acvars in
-  let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
-  let onlyparse = is_not_printable onlyparse (not reversible) ac in
-  let notation = {
-    notobj_local = local;
-    notobj_scope = scope;
-    notobj_interp = (List.map_filter map i_vars, ac);
-    (** Order is important here! *)
-    notobj_onlyparse = onlyparse;
-    notobj_onlyprint = onlyprint;
-    notobj_compat = compat;
-    notobj_notation = df';
-  } in
-  Lib.add_anonymous_leaf (inNotation notation);
-  df'
-
-(* Notations without interpretation (Reserved Notation) *)
-
-let add_syntax_extension local ((loc,df),mods) =
-  let msgs, sy_data, extra, onlyprint = compute_pure_syntax_data df mods in
-  let sy_rules = make_syntax_rules sy_data extra onlyprint None in
-  Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
-  Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
-
-(* Notations with only interpretation *)
-
-let add_notation_interpretation ((loc,df),c,sc) =
-  let df' = add_notation_interpretation_core false df c sc false false None in
-  Dumpglob.dump_notation (loc,df') sc true
-
-let set_notation_for_interpretation impls ((_,df),c,sc) =
-  (try ignore
-    (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
-  with NoSyntaxRule ->
-    error "Parsing rule for this notation has to be previously declared.");
-  Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc
-
-(* Main entry point *)
-
-let add_notation local c ((loc,df),modifiers) sc =
-  let df' =
-   if no_syntax_modifiers modifiers then
-    (* No syntax data: try to rely on a previously declared rule *)
-    let onlyparse = is_only_parsing modifiers in
-    let onlyprint = is_only_printing modifiers in
-    let compat = get_compat_version modifiers in
-    try add_notation_interpretation_core local df c sc onlyparse onlyprint compat
-    with NoSyntaxRule ->
-      (* Try to determine a default syntax rule *)
-      add_notation_in_scope local df c modifiers sc
-   else
-    (* Declare both syntax and interpretation *)
-    add_notation_in_scope local df c modifiers sc
-  in
-  Dumpglob.dump_notation (loc,df') sc true
-
-let add_notation_extra_printing_rule df k v =
-  let notk = 
-    let dfs = split_notation_string df in
-    let _,_, symbs = analyze_notation_tokens dfs in
-    make_notation_key symbs in
-  Notation.add_notation_extra_printing_rule notk k v
-
-(* Infix notations *)
-
-let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None)
-
-let add_infix local ((loc,inf),modifiers) pr sc =
-  check_infix_modifiers modifiers;
-  (* check the precedence *)
-  let metas = [inject_var "x"; inject_var "y"] in
-  let c = mkAppC (pr,metas) in
-  let df = "x "^(quote_notation_token inf)^" y" in
-  add_notation local c ((loc,df),modifiers) sc
-
-(**********************************************************************)
-(* Delimiters and classes bound to scopes                             *)
-
-type scope_command =
-  | ScopeDelim of string
-  | ScopeClasses of scope_class list
-  | ScopeRemove
-
-let load_scope_command _ (_,(scope,dlm)) =
-  Notation.declare_scope scope
-
-let open_scope_command i (_,(scope,o)) =
-  if Int.equal i 1 then
-    match o with
-    | ScopeDelim dlm -> Notation.declare_delimiters scope dlm
-    | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl
-    | ScopeRemove -> Notation.remove_delimiters scope
-
-let cache_scope_command o =
-  load_scope_command 1 o;
-  open_scope_command 1 o
-
-let subst_scope_command (subst,(scope,o as x)) = match o with
-  | ScopeClasses cl ->
-      let cl' = List.map_filter (subst_scope_class subst) cl in
-      let cl' =
-        if List.for_all2eq (==) cl cl' then cl
-        else cl' in
-      scope, ScopeClasses cl'
-  | _ -> x
-
-let inScopeCommand : scope_name * scope_command -> obj =
-  declare_object {(default_object "DELIMITERS") with
-      cache_function = cache_scope_command;
-      open_function = open_scope_command;
-      load_function = load_scope_command;
-      subst_function = subst_scope_command;
-      classify_function = (fun obj -> Substitute obj)}
-
-let add_delimiters scope key =
-  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key))
-
-let remove_delimiters scope =
-  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove))
-
-let add_class_scope scope cl =
-  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl))
-
-(* Check if abbreviation to a name and avoid early insertion of
-   maximal implicit arguments *)
-let try_interp_name_alias = function
-  | [], CRef (ref,_) -> intern_reference ref
-  | _ -> raise Not_found
-
-let add_syntactic_definition ident (vars,c) local onlyparse =
-  let nonprintable = ref false in
-  let vars,pat =
-    try [], NRef (try_interp_name_alias (vars,c))
-    with Not_found ->
-      let fold accu id = Id.Map.add id NtnInternTypeConstr accu in
-      let i_vars = List.fold_left fold Id.Map.empty vars in
-      let nenv = {
-        ninterp_var_type = i_vars;
-        ninterp_rec_vars = Id.Map.empty;
-      } in
-      let nvars, pat, reversible = interp_notation_constr nenv c in
-      let () = nonprintable := not reversible in
-      let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in
-      List.map map vars, pat
-  in
-  let onlyparse = match onlyparse with
-    | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current
-    | p -> p
-  in
-  Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
-
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
deleted file mode 100644
index 085cc87c..00000000
--- a/toplevel/metasyntax.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Tacexpr
-open Vernacexpr
-open Notation
-open Constrexpr
-open Notation_term
-
-val add_token_obj : string -> unit
-
-(** Adding a (constr) notation in the environment*)
-
-val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
-  constr_expr -> scope_name option -> unit
-
-val add_notation : locality_flag -> constr_expr ->
-  (lstring * syntax_modifier list) -> scope_name option -> unit
-
-val add_notation_extra_printing_rule : string -> string -> string -> unit
-
-(** Declaring delimiter keys and default scopes *)
-
-val add_delimiters : scope_name -> string -> unit
-val remove_delimiters : scope_name -> unit
-val add_class_scope : scope_name -> scope_class list -> unit
-
-(** Add only the interpretation of a notation that already has pa/pp rules *)
-
-val add_notation_interpretation :
-  (lstring * constr_expr * scope_name option) -> unit
-
-(** Add a notation interpretation for supporting the "where" clause *)
-
-val set_notation_for_interpretation : Constrintern.internalization_env ->
-  (lstring * constr_expr * scope_name option) -> unit
-
-(** Add only the parsing/printing rule of a notation *)
-
-val add_syntax_extension :
-  locality_flag -> (lstring * syntax_modifier list) -> unit
-
-(** Add a syntactic definition (as in "Notation f := ...") *)
-
-val add_syntactic_definition : Id.t -> Id.t list * constr_expr ->
-  bool -> Flags.compat_version option -> unit
-
-(** Print the Camlp4 state of a grammar *)
-
-val pr_grammar : string -> Pp.std_ppcmds
-
-val check_infix_modifiers : syntax_modifier list -> unit
-
-val with_syntax_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
deleted file mode 100644
index b6690fe4..00000000
--- a/toplevel/mltop.ml
+++ /dev/null
@@ -1,447 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open CErrors
-open Util
-open Pp
-open Flags
-open Libobject
-open System
-
-(* Code to hook Coq into the ML toplevel -- depends on having the
-   objective-caml compiler mostly visible. The functions implemented here are:
-   \begin{itemize}
-   \item [dir_ml_load name]: Loads the ML module fname from the current ML
-     path.
-   \item [dir_ml_use]: Directive #use of Ocaml toplevel
-   \item [add_ml_dir]: Directive #directory of Ocaml toplevel
-   \end{itemize}
-
-   How to build an ML module interface with these functions.
-   The idea is that the ML directory path is like the Coq directory
-   path.  So we can maintain the two in parallel.
-   In the same way, we can use the "ml_env" as a kind of ML
-   environment, which we freeze, unfreeze, and add things to just like
-   to the other environments.
-   Finally, we can create an object which is an ML module, and require
-   that the "caching" of the ML module cause the loading of the
-   associated ML file, if that file has not been yet loaded.  Of
-   course, the problem is how to record dependencies between ML
-   modules.
-   (I do not know of a solution to this problem, other than to
-   put all the needed names into the ML Module object.) *)
-
-
-(* NB: this module relies on OCaml's Dynlink library. The bytecode version
-   of Dynlink is always available, but there are some architectures
-   with native compilation and no dynlink.cmxa. Instead of nasty IFDEF's
-   here for hiding the calls to Dynlink, we now simply reject this rather
-   rare situation during ./configure, and give instructions there about how
-   to build a dummy dynlink.cmxa, cf. dev/dynlink.ml. *)
-
-(* This path is where we look for .cmo *)
-let coq_mlpath_copy = ref [Sys.getcwd ()]
-let keep_copy_mlpath path =
-  let cpath = CUnix.canonical_path_name path in
-  let filter path' = not (String.equal cpath path')
-  in
-  coq_mlpath_copy := cpath :: List.filter filter !coq_mlpath_copy
-
-(* If there is a toplevel under Coq *)
-type toplevel = {
-  load_obj : string -> unit;
-  use_file : string -> unit;
-  add_dir  : string -> unit;
-  ml_loop  : unit -> unit }
-
-(* Determines the behaviour of Coq with respect to ML files (compiled
-   or not) *)
-type kind_load =
-  | WithTop of toplevel
-  | WithoutTop
-
-(* Must be always initialized *)
-let load = ref WithoutTop
-
-(* Are we in a native version of Coq? *)
-let is_native = Dynlink.is_native
-
-(* Sets and initializes a toplevel (if any) *)
-let set_top toplevel = load :=
-  WithTop toplevel;
-  Nativelib.load_obj := toplevel.load_obj
-
-(* Removes the toplevel (if any) *)
-let remove () =
-  load := WithoutTop;
-  Nativelib.load_obj := (fun x -> () : string -> unit)
-
-(* Tests if an Ocaml toplevel runs under Coq *)
-let is_ocaml_top () =
-  match !load with
-    | WithTop _ -> true
-    |_ -> false
-
-(* Tests if we can load ML files *)
-let has_dynlink = Coq_config.has_natdynlink || not is_native
-
-(* Runs the toplevel loop of Ocaml *)
-let ocaml_toploop () =
-  match !load with
-    | WithTop t -> Printexc.catch t.ml_loop ()
-    | _ -> ()
-
-(* Try to interpret load_obj's (internal) errors *)
-let report_on_load_obj_error exc =
-  let x = Obj.repr exc in
-  (* Try an horrible (fragile) hack to report on Symtable dynlink errors *)
-  (* (we follow ocaml's Printexc.to_string decoding of exceptions) *)
-  if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error"
-  then
-    let err_block = Obj.field x 1 in
-    if Int.equal (Obj.tag err_block) 0 then
-      (* Symtable.Undefined_global of string *)
-      str "reference to undefined global " ++
-      str (Obj.magic (Obj.field err_block 0))
-    else str (Printexc.to_string exc)
-  else str (Printexc.to_string exc)
-
-(* Dynamic loading of .cmo/.cma *)
-
-let ml_load s =
-  match !load with
-    | WithTop t ->
-      (try t.load_obj s; s
-       with
-       | e when CErrors.noncritical e ->
-        let e = CErrors.push e in
-        match fst e with
-        | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e)
-        | exc ->
-            let msg = report_on_load_obj_error exc in
-            errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++
-                  str s ++ str" to Coq code (" ++ msg ++ str ")."))
-    | WithoutTop ->
-        try
-          Dynlink.loadfile s; s
-	with Dynlink.Error a ->
-          errorlabstrm "Mltop.load_object"
-            (strbrk "while loading " ++ str s ++
-             strbrk ": " ++ str (Dynlink.error_message a))
-
-let dir_ml_load s =
-  match !load with
-    | WithTop _ -> ml_load s
-    | WithoutTop ->
-        let warn = Flags.is_verbose() in
-        let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in
-        ml_load gname
-
-(* Dynamic interpretation of .ml *)
-let dir_ml_use s =
-  match !load with
-    | WithTop t -> t.use_file s
-    | _ ->
-       let moreinfo =
-	 if Dynlink.is_native then " Loading ML code works only in bytecode."
-	 else ""
-       in
-      errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo)
-
-(* Adds a path to the ML paths *)
-let add_ml_dir s =
-  match !load with
-    | WithTop t -> t.add_dir s; keep_copy_mlpath s
-    | WithoutTop when has_dynlink -> keep_copy_mlpath s
-    | _ -> ()
-
-(* For Rec Add ML Path (-R) *)
-let add_rec_ml_dir unix_path =
-  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
-
-(* Adding files to Coq and ML loadpath *)
-
-let warn_cannot_use_directory =
-  CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem"
-         (fun d ->
-          str "Directory " ++ str d ++
-            strbrk " cannot be used as a Coq identifier (skipped)")
-
-let convert_string d =
-  try Names.Id.of_string d
-  with UserError _ ->
-    warn_cannot_use_directory d;
-    raise Exit
-
-let warn_cannot_open_path =
-  CWarnings.create ~name:"cannot-open-path" ~category:"filesystem"
-      (fun unix_path -> str "Cannot open " ++ str unix_path)
-
-type add_ml = AddNoML | AddTopML | AddRecML
-
-let add_rec_path add_ml ~unix_path ~coq_root ~implicit =
-  if exists_dir unix_path then
-    let dirs = all_subdirs ~unix_path in
-    let prefix = Names.DirPath.repr coq_root in
-    let convert_dirs (lp, cp) =
-      try
-        let path = List.rev_map convert_string cp @ prefix in
-        Some (lp, Names.DirPath.make path)
-      with Exit -> None
-    in
-    let dirs = List.map_filter convert_dirs dirs in
-    let () = match add_ml with
-      | AddNoML -> ()
-      | AddTopML -> add_ml_dir unix_path
-      | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in
-    let add (path, dir) =
-      Loadpath.add_load_path path ~implicit dir in
-    let () = List.iter add dirs in
-    Loadpath.add_load_path unix_path ~implicit coq_root
-  else
-    warn_cannot_open_path unix_path
-
-(* convertit un nom quelconque en nom de fichier ou de module *)
-let mod_of_name name =
-    if Filename.check_suffix name ".cmo" then
-      Filename.chop_suffix name ".cmo"
-    else
-      name
-
-let get_ml_object_suffix name =
-  if Filename.check_suffix name ".cmo" then
-    Some ".cmo"
-  else if Filename.check_suffix name ".cma" then
-    Some ".cma"
-  else if Filename.check_suffix name ".cmxs" then
-    Some ".cmxs"
-  else
-    None
-
-let file_of_name name =
-  let suffix = get_ml_object_suffix name in
-  let fail s =
-    errorlabstrm "Mltop.load_object"
-      (str"File not found on loadpath : " ++ str s ++ str"\n" ++
-       str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in
-  if not (Filename.is_relative name) then
-    if Sys.file_exists name then name else fail name
-  else if is_native then
-    let name = match suffix with
-      | Some ((".cmo"|".cma") as suffix) ->
-          (Filename.chop_suffix name suffix) ^ ".cmxs"
-      | Some ".cmxs" -> name
-      | _ -> name ^ ".cmxs"
-    in
-    if is_in_path !coq_mlpath_copy name then name else fail name
-  else
-    let (full, base) = match suffix with
-      | Some ".cmo" | Some ".cma" -> true, name
-      | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs"
-      | _ -> false, name
-    in
-    if full then
-      if is_in_path !coq_mlpath_copy base then base else fail base
-    else
-      let name = base ^ ".cma" in
-      if is_in_path !coq_mlpath_copy name then name else
-        let name = base ^ ".cmo" in
-        if is_in_path !coq_mlpath_copy name then name else
-          fail (base ^ ".cm[ao]")
-
-(** Is the ML code of the standard library placed into loadable plugins
-    or statically compiled into coqtop ? For the moment this choice is
-    made according to the presence of native dynlink : even if bytecode
-    coqtop could always load plugins, we prefer to have uniformity between
-    bytecode and native versions. *)
-
-(* [known_loaded_module] contains the names of the loaded ML modules
- * (linked or loaded with load_object). It is used not to load a
- * module twice. It is NOT the list of ML modules Coq knows. *)
-
-let known_loaded_modules = ref String.Map.empty
-
-let add_known_module mname path =
-  if not (String.Map.mem mname !known_loaded_modules) ||
-     String.Map.find mname !known_loaded_modules = None then
-    known_loaded_modules := String.Map.add mname path !known_loaded_modules
-
-let module_is_known mname =
-  String.Map.mem mname !known_loaded_modules
-
-let known_module_path mname =
-  String.Map.find mname !known_loaded_modules
-
-(** A plugin is just an ML module with an initialization function. *)
-
-let known_loaded_plugins = ref String.Map.empty
-
-let add_known_plugin init name =
-  add_known_module name None;
-  known_loaded_plugins := String.Map.add name init !known_loaded_plugins
-
-let init_known_plugins () =
-  String.Map.iter (fun _ f -> f()) !known_loaded_plugins
-
-(** Registering functions to be used at caching time, that is when the Declare
-    ML module command is issued. *)
-
-let cache_objs = ref String.Map.empty
-
-let declare_cache_obj f name =
-  let objs = try String.Map.find name !cache_objs with Not_found -> [] in
-  let objs = f :: objs in
-  cache_objs := String.Map.add name objs !cache_objs
-
-let perform_cache_obj name =
-  let objs = try String.Map.find name !cache_objs with Not_found -> [] in
-  let objs = List.rev objs in
-  List.iter (fun f -> f ()) objs
-
-(** ml object = ml module or plugin *)
-
-let init_ml_object mname =
-  try String.Map.find mname !known_loaded_plugins ()
-  with Not_found -> ()
-
-let load_ml_object mname ?path fname=
-  let path = match path with
-    | None -> dir_ml_load fname
-    | Some p -> ml_load p in
-  add_known_module mname (Some path);
-  init_ml_object mname;
-  path
-
-let dir_ml_load m = ignore(dir_ml_load m)
-let add_known_module m = add_known_module m None
-let load_ml_object_raw fname = dir_ml_load (file_of_name fname)
-let load_ml_objects_raw_rex rex =
-  List.iter (fun (_,fp) ->
-    let name = file_of_name (Filename.basename fp) in
-    try dir_ml_load name
-    with e -> prerr_endline (Printexc.to_string e))
-    (System.where_in_path_rex !coq_mlpath_copy rex)
-
-(* Summary of declared ML Modules *)
-
-(* List and not String.Set because order is important: most recent first. *)
-
-let loaded_modules = ref []
-let get_loaded_modules () = List.rev !loaded_modules
-let add_loaded_module md path =
-  if not (List.mem_assoc md !loaded_modules) then
-    loaded_modules := (md,path) :: !loaded_modules
-let reset_loaded_modules () = loaded_modules := []
-
-let if_verbose_load verb f name ?path fname =
-  if not verb then f name ?path fname
-  else
-    let info = str "[Loading ML file " ++ str fname ++ str " ..." in
-    try
-      let path = f name ?path fname in
-      Feedback.msg_info (info ++ str " done]");
-      path
-    with reraise ->
-      Feedback.msg_info (info ++ str " failed]");
-      raise reraise
-
-(** Load a module for the first time (i.e. dynlink it)
-    or simulate its reload (i.e. doing nothing except maybe
-    an initialization function). *)
-
-let trigger_ml_object verb cache reinit ?path name =
-  if module_is_known name then begin
-    if reinit then init_ml_object name;
-    add_loaded_module name (known_module_path name);
-    if cache then perform_cache_obj name
-  end else if not has_dynlink then
-    errorlabstrm "Mltop.trigger_ml_object"
-      (str "Dynamic link not supported (module " ++ str name ++ str ")")
-  else begin
-    let file = file_of_name (Option.default name path) in
-    let path =
-      if_verbose_load (verb && is_verbose ()) load_ml_object name ?path file in
-    add_loaded_module name (Some path);
-    if cache then perform_cache_obj name
-  end
-
-let load_ml_object n m = ignore(load_ml_object n m)
-
-let unfreeze_ml_modules x =
-  reset_loaded_modules ();
-  List.iter
-    (fun (name,path) -> trigger_ml_object false false false ?path name) x
-
-let _ =
-  Summary.declare_summary Summary.ml_modules
-    { Summary.freeze_function = (fun _ -> get_loaded_modules ());
-      Summary.unfreeze_function = unfreeze_ml_modules;
-      Summary.init_function = reset_loaded_modules }
-
-(* Liboject entries of declared ML Modules *)
-
-type ml_module_object = {
-  mlocal : Vernacexpr.locality_flag;
-  mnames : string list
-}
-
-let cache_ml_objects (_,{mnames=mnames}) =
-  let iter obj = trigger_ml_object true true true obj in
-  List.iter iter mnames
-
-let load_ml_objects _ (_,{mnames=mnames}) =
-  let iter obj = trigger_ml_object true false true obj in
-  List.iter iter mnames
-
-let classify_ml_objects ({mlocal=mlocal} as o) =
-  if mlocal then Dispose else Substitute o
-
-let inMLModule : ml_module_object -> obj =
-  declare_object
-    {(default_object "ML-MODULE") with
-      cache_function = cache_ml_objects;
-      load_function = load_ml_objects;
-      subst_function = (fun (_,o) -> o);
-      classify_function = classify_ml_objects }
-
-let declare_ml_modules local l =
-  let l = List.map mod_of_name l in
-  Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l})
-
-let print_ml_path () =
-  let l = !coq_mlpath_copy in
-  str"ML Load Path:" ++ fnl () ++ str"  " ++
-          hv 0 (prlist_with_sep fnl str l)
-
-(* Printing of loaded ML modules *)
-
-let print_ml_modules () =
-  let l = get_loaded_modules () in
-  str"Loaded ML Modules: " ++ pr_vertical_list str (List.map fst l)
-
-let print_gc () =
-  let stat = Gc.stat () in
-  let msg =
-    str "minor words: " ++ real stat.Gc.minor_words ++ fnl () ++
-    str "promoted words: " ++ real stat.Gc.promoted_words ++ fnl () ++
-    str "major words: " ++ real stat.Gc.major_words ++ fnl () ++
-    str "minor_collections: " ++ int stat.Gc.minor_collections ++ fnl () ++
-    str "major_collections: " ++ int stat.Gc.major_collections ++ fnl () ++
-    str "heap_words: " ++ int stat.Gc.heap_words ++ fnl () ++
-    str "heap_chunks: " ++ int stat.Gc.heap_chunks ++ fnl () ++
-    str "live_words: " ++ int stat.Gc.live_words ++ fnl () ++
-    str "live_blocks: " ++ int stat.Gc.live_blocks ++ fnl () ++
-    str "free_words: " ++ int stat.Gc.free_words ++ fnl () ++
-    str "free_blocks: " ++ int stat.Gc.free_blocks ++ fnl () ++
-    str "largest_free: " ++ int stat.Gc.largest_free ++ fnl () ++
-    str "fragments: " ++ int stat.Gc.fragments ++ fnl () ++
-    str "compactions: " ++ int stat.Gc.compactions ++ fnl () ++
-    str "top_heap_words: " ++ int stat.Gc.top_heap_words ++ fnl () ++
-    str "stack_size: " ++ int stat.Gc.stack_size
-  in
-  hv 0 msg
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
deleted file mode 100644
index 6633cb93..00000000
--- a/toplevel/mltop.mli
+++ /dev/null
@@ -1,88 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** {5 Toplevel management} *)
-
-(** If there is a toplevel under Coq, it is described by the following
-   record. *)
-type toplevel = {
-  load_obj : string -> unit;
-  use_file : string -> unit;
-  add_dir  : string -> unit;
-  ml_loop  : unit -> unit }
-
-(** Sets and initializes a toplevel (if any) *)
-val set_top : toplevel -> unit
-
-(** Are we in a native version of Coq? *)
-val is_native : bool
-
-(** Removes the toplevel (if any) *)
-val remove : unit -> unit
-
-(** Tests if an Ocaml toplevel runs under Coq *)
-val is_ocaml_top : unit -> bool
-
-(** Starts the Ocaml toplevel loop *)
-val ocaml_toploop : unit -> unit
-
-(** {5 ML Dynlink} *)
-
-(** Tests if we can load ML files *)
-val has_dynlink : bool
-
-(** Dynamic loading of .cmo *)
-val dir_ml_load : string -> unit
-
-(** Dynamic interpretation of .ml *)
-val dir_ml_use : string -> unit
-
-(** Adds a path to the ML paths *)
-val add_ml_dir : string -> unit
-val add_rec_ml_dir : string -> unit
-
-type add_ml = AddNoML | AddTopML | AddRecML
-
-(** Adds a path to the Coq and ML paths *)
-val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
-
-(** List of modules linked to the toplevel *)
-val add_known_module : string -> unit
-val module_is_known : string -> bool
-val load_ml_object : string -> string -> unit
-val load_ml_object_raw : string -> unit
-val load_ml_objects_raw_rex : Str.regexp -> unit
-
-(** {5 Initialization functions} *)
-
-(** Declare a plugin and its initialization function.
-    A plugin is just an ML module with an initialization function.
-    Adding a known plugin implies adding it as a known ML module.
-    The initialization function is granted to be called after Coq is fully
-    bootstrapped, even if the plugin is statically linked with the toplevel *)
-val add_known_plugin : (unit -> unit) -> string -> unit
-
-(** Calls all initialization functions in a non-specified order *)
-val init_known_plugins : unit -> unit
-
-(** Register a callback that will be called when the module is declared with
-    the Declare ML Module command. This is useful to define Coq objects at that
-    time only. Several functions can be defined for one module; they will be
-    called in the order of declaration, and after the ML module has been
-    properly initialized. *)
-val declare_cache_obj : (unit -> unit) -> string -> unit
-
-(** {5 Declaring modules} *)
-
-val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit
-
-(** {5 Utilities} *)
-
-val print_ml_path : unit -> Pp.std_ppcmds
-val print_ml_modules : unit -> Pp.std_ppcmds
-val print_gc : unit -> Pp.std_ppcmds
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
deleted file mode 100644
index 29d74573..00000000
--- a/toplevel/obligations.ml
+++ /dev/null
@@ -1,1171 +0,0 @@
-open Printf
-open Globnames
-open Libobject
-open Entries
-open Decl_kinds
-open Declare
-
-(**
-   - Get types of existentials ;
-   - Flatten dependency tree (prefix order) ;
-   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
-   - Apply term prefixed by quantification on "existentials".
-*)
-
-open Term
-open Vars
-open Names
-open Evd
-open Pp
-open CErrors
-open Util
-
-let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false)
-let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false)
-
-let succfix (depth, fixrels) =
-  (succ depth, List.map succ fixrels)
-
-let check_evars env evm =
-  Evar.Map.iter
-  (fun key evi ->
-   let (loc,k) = evar_source key evm in
-     match k with
-     | Evar_kinds.QuestionMark _
-     | Evar_kinds.ImplicitArg (_,_,false) -> ()
-     | _ ->
-       Pretype_errors.error_unsolvable_implicit loc env evm key None)
-  (Evd.undefined_map evm)
-
-type oblinfo =
-  { ev_name: int * Id.t;
-    ev_hyps: Context.Named.t;
-    ev_status: bool * Evar_kinds.obligation_definition_status;
-    ev_chop: int option;
-    ev_src: Evar_kinds.t Loc.located;
-    ev_typ: types;
-    ev_tac: unit Proofview.tactic option;
-    ev_deps: Int.Set.t }
-
-(** Substitute evar references in t using De Bruijn indices,
-  where n binders were passed through. *)
-
-let subst_evar_constr evs n idf t =
-  let open Context.Named.Declaration in
-  let seen = ref Int.Set.empty in
-  let transparent = ref Id.Set.empty in
-  let evar_info id = List.assoc_f Evar.equal id evs in
-  let rec substrec (depth, fixrels) c = match kind_of_term c with
-    | Evar (k, args) ->
-	let { ev_name = (id, idstr) ;
-	      ev_hyps = hyps ; ev_chop = chop } =
-	  try evar_info k
-	  with Not_found ->
-	    anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found")
-	in
-        seen := Int.Set.add id !seen;
-	  (* Evar arguments are created in inverse order,
-	     and we must not apply to defined ones (i.e. LetIn's)
-	  *)
-	let args =
-	  let n = match chop with None -> 0 | Some c -> c in
-	  let (l, r) = List.chop n (List.rev (Array.to_list args)) in
-	    List.rev r
-	in
-	let args =
-	  let rec aux hyps args acc =
-	     match hyps, args with
-		 (LocalAssum _ :: tlh), (c :: tla) ->
-		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
-	       | (LocalDef _ :: tlh), (_ :: tla) ->
-		   aux tlh tla acc
-	       | [], [] -> acc
-	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
-	  in aux hyps args []
-	in
-	  if List.exists
-            (fun x -> match kind_of_term x with
-            | Rel n -> Int.List.mem n fixrels
-            | _ -> false) args
-          then
-	    transparent := Id.Set.add idstr !transparent;
-	  mkApp (idf idstr, Array.of_list args)
-    | Fix _ ->
-	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
-    | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
-  in
-  let t' = substrec (0, []) t in
-    t', !seen, !transparent
-
-
-(** Substitute variable references in t using De Bruijn indices,
-  where n binders were passed through. *)
-let subst_vars acc n t =
-  let var_index id = Util.List.index Id.equal id acc in
-  let rec substrec depth c = match kind_of_term c with
-    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in
-    substrec 0 t
-
-(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
-    to a product : forall H1 : t1, ..., forall Hn : tn, concl.
-    Changes evars and hypothesis references to variable references.
-*)
-let etype_of_evar evs hyps concl =
-  let open Context.Named.Declaration in
-  let rec aux acc n = function
-      decl :: tl ->
-	let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in
-	let t'' = subst_vars acc 0 t' in
-	let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in
-	let s' = Int.Set.union s s' in
-	let trans' = Id.Set.union trans trans' in
-	  (match decl with
-            | LocalDef (id,c,_) ->
-		let c', s'', trans'' = subst_evar_constr evs n mkVar c in
-		let c' = subst_vars acc 0 c' in
-		  mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest,
-		Int.Set.union s'' s',
-		Id.Set.union trans'' trans'
-	    | LocalAssum (id,_) ->
-		mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans')
-    | [] ->
-	let t', s, trans = subst_evar_constr evs n mkVar concl in
-	  subst_vars acc 0 t', s, trans
-  in aux [] 0 (List.rev hyps)
-
-let trunc_named_context n ctx =
-  let len = List.length ctx in
-    List.firstn (len - n) ctx
-
-let rec chop_product n t =
-  if Int.equal n 0 then Some t
-  else
-    match kind_of_term t with
-      | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
-      | _ -> None
-
-let evar_dependencies evm oev =
-  let one_step deps =
-    Evar.Set.fold (fun ev s ->
-      let evi = Evd.find evm ev in
-      let deps' = evars_of_filtered_evar_info evi in
-      if Evar.Set.mem oev deps' then
-	invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev)
-      else Evar.Set.union deps' s)
-      deps deps
-  in
-  let rec aux deps =
-    let deps' = one_step deps in
-      if Evar.Set.equal deps deps' then deps
-      else aux deps'
-  in aux (Evar.Set.singleton oev)
-      
-let move_after (id, ev, deps as obl) l = 
-  let rec aux restdeps = function
-    | (id', _, _) as obl' :: tl -> 
-	let restdeps' = Evar.Set.remove id' restdeps in
-	  if Evar.Set.is_empty restdeps' then
-	    obl' :: obl :: tl
-	  else obl' :: aux restdeps' tl
-    | [] -> [obl]
-  in aux (Evar.Set.remove id deps) l
-    
-let sort_dependencies evl =
-  let rec aux l found list =
-    match l with
-    | (id, ev, deps) as obl :: tl ->
-	let found' = Evar.Set.union found (Evar.Set.singleton id) in
-	  if Evar.Set.subset deps found' then
-	    aux tl found' (obl :: list)
-	  else aux (move_after obl tl) found list
-    | [] -> List.rev list
-  in aux evl Evar.Set.empty []
-
-open Environ
-
-let eterm_obligations env name evm fs ?status t ty = 
-  (* 'Serialize' the evars *)
-  let nc = Environ.named_context env in
-  let nc_len = Context.Named.length nc in
-  let evm = Evarutil.nf_evar_map_undefined evm in
-  let evl = Evarutil.non_instantiated evm in
-  let evl = Evar.Map.bindings evl in
-  let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
-  let sevl = sort_dependencies evl in
-  let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
-  let evn =
-    let i = ref (-1) in
-      List.rev_map (fun (id, ev) -> incr i;
-		      (id, (!i, Id.of_string
-			      (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))),
-		       ev)) evl
-  in
-  let evts =
-    (* Remove existential variables in types and build the corresponding products *)
-    List.fold_right
-      (fun (id, (n, nstr), ev) l ->
-	 let hyps = Evd.evar_filtered_context ev in
-	 let hyps = trunc_named_context nc_len hyps in
-	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
-	 let evtyp, hyps, chop =
-	   match chop_product fs evtyp with
-	   | Some t -> t, trunc_named_context fs hyps, fs
-	   | None -> evtyp, hyps, 0
-	 in
-	 let loc, k = evar_source id evm in
-	 let status = match k with
-           | Evar_kinds.QuestionMark o -> o
-           | _ -> match status with
-                 | Some o -> o
-                 | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ()))
-         in
-         let force_status, status, chop = match status with
-	   | Evar_kinds.Define true as stat ->
-	      if not (Int.equal chop fs) then true, Evar_kinds.Define false, None
-	      else false, stat, Some chop
-	   | s -> false, s, None
-	 in
-	 let info = { ev_name = (n, nstr);
-		      ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop;
-		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None }
-	 in (id, info) :: l)
-      evn []
-  in
-  let t', _, transparent = (* Substitute evar refs in the term by variables *)
-    subst_evar_constr evts 0 mkVar t 
-  in
-  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
-  let evars = 
-    List.map (fun (ev, info) ->
-      let { ev_name = (_, name); ev_status = force_status, status;
-	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
-      in
-      let force_status, status = match status with
-	| Evar_kinds.Define true when Id.Set.mem name transparent ->
-	  true, Evar_kinds.Define false
-	| _ -> force_status, status
-      in name, typ, src, (force_status, status), deps, tac) evts
-  in
-  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
-  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
-    Array.of_list (List.rev evars), (evnames, evmap), t', ty
-
-let tactics_module = ["Program";"Tactics"]
-let safe_init_constant md name () =
-  Coqlib.check_required_library ("Coq"::md);
-  Coqlib.gen_constant "Obligations" md name
-let hide_obligation = safe_init_constant tactics_module "obligation"
-
-let pperror cmd = CErrors.errorlabstrm "Program" cmd
-let error s = pperror (str s)
-
-let reduce c =
-  Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty c
-
-exception NoObligations of Id.t option
-
-let explain_no_obligations = function
-    Some ident -> str "No obligations for program " ++ Id.print ident
-  | None -> str "No obligations remaining"
-
-type obligation_info =
-    (Names.Id.t * Term.types * Evar_kinds.t Loc.located *
-       (bool * Evar_kinds.obligation_definition_status)
-       * Int.Set.t * unit Proofview.tactic option) array
-
-type 'a obligation_body = 
-  | DefinedObl of 'a
-  | TermObl of constr
-
-type obligation =
-  { obl_name : Id.t;
-    obl_type : types;
-    obl_location : Evar_kinds.t Loc.located;
-    obl_body : constant obligation_body option;
-    obl_status : bool * Evar_kinds.obligation_definition_status;
-    obl_deps : Int.Set.t;
-    obl_tac : unit Proofview.tactic option;
-  }
-
-type obligations = (obligation array * int)
-
-type fixpoint_kind =
-  | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
-  | IsCoFixpoint
-
-type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
-
-type program_info_aux = {
-  prg_name: Id.t;
-  prg_body: constr;
-  prg_type: constr;
-  prg_ctx:  Evd.evar_universe_context;
-  prg_pl: Id.t Loc.located list option;
-  prg_obligations: obligations;
-  prg_deps : Id.t list;
-  prg_fixkind : fixpoint_kind option ;
-  prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list;
-  prg_notations : notations ;
-  prg_kind : definition_kind;
-  prg_reduce : constr -> constr;
-  prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook;
-  prg_opaque : bool;
-  prg_sign: named_context_val;
-}
-
-type program_info = program_info_aux CEphemeron.key
-
-let get_info x =
-  try CEphemeron.get x
-  with CEphemeron.InvalidKey ->
-    CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker")
-
-let assumption_message = Declare.assumption_message
-
-let default_tactic = ref (Proofview.tclUNIT ())
-
-(* true = hide obligations *)
-let hide_obligations = ref false
-
-let set_hide_obligations = (:=) hide_obligations
-let get_hide_obligations () = !hide_obligations
-
-open Goptions
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "Hidding of Program obligations";
-      optkey   = ["Hide";"Obligations"];
-      optread  = get_hide_obligations;
-      optwrite = set_hide_obligations; }
-
-let shrink_obligations = ref true
-
-let set_shrink_obligations = (:=) shrink_obligations
-let get_shrink_obligations () = !shrink_obligations
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = true;
-      optname  = "Shrinking of Program obligations";
-      optkey   = ["Shrink";"Obligations"];
-      optread  = get_shrink_obligations;
-      optwrite = set_shrink_obligations; }
-
-let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
-
-let get_body obl =
-  match obl.obl_body with
-  | None -> None
-  | Some (DefinedObl c) ->
-    let ctx = Environ.constant_context (Global.env ()) c in
-    let pc = (c, Univ.UContext.instance ctx) in
-      Some (DefinedObl pc)
-  | Some (TermObl c) ->
-      Some (TermObl c)
-
-let get_obligation_body expand obl =
-  match get_body obl with
-  | None -> None
-  | Some c ->
-     if expand && snd obl.obl_status == Evar_kinds.Expand then
-       match c with
-       | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc)
-       | TermObl c -> Some c
-     else (match c with
-	   | DefinedObl pc -> Some (mkConstU pc)
-	   | TermObl c -> Some c)
-
-let obl_substitution expand obls deps =
-  Int.Set.fold
-    (fun x acc ->
-       let xobl = obls.(x) in
-       match get_obligation_body expand xobl with
-       | None -> acc
-       | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
-    deps []
-
-let subst_deps expand obls deps t =
-  let osubst = obl_substitution expand obls deps in
-    (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t)
-
-let rec prod_app t n =
-  match kind_of_term (strip_outer_cast t) with
-    | Prod (_,_,b) -> subst1 n b
-    | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
-    | _ ->
-	errorlabstrm "prod_app"
-	  (str"Needed a product, but didn't find one" ++ fnl ())
-
-
-(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
-let prod_applist t nL = List.fold_left prod_app t nL
-
-let replace_appvars subst =
-  let rec aux c = 
-    let f, l = decompose_app c in
-      if isVar f then
-	try
-	  let c' = List.map (map_constr aux) l in
-	  let (t, b) = Id.List.assoc (destVar f) subst in
-	    mkApp (delayed_force hide_obligation, 
-		   [| prod_applist t c'; applistc b c' |])
-	with Not_found -> map_constr aux c
-      else map_constr aux c
-  in map_constr aux
-       
-let subst_prog expand obls ints prg =
-  let subst = obl_substitution expand obls ints in
-    if get_hide_obligations () then
-      (replace_appvars subst prg.prg_body,
-       replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type))
-    else 
-      let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
-	(Vars.replace_vars subst' prg.prg_body,
-	 Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type))
-
-let subst_deps_obl obls obl =
-  let t' = subst_deps true obls obl.obl_deps obl.obl_type in
-    { obl with obl_type = t' }
-
-module ProgMap = Id.Map
-
-let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m)
-
-let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
-
-let from_prg : program_info ProgMap.t ref =
-  Summary.ref ProgMap.empty ~name:"program-tcc-table"
-
-let close sec =
-  if not (ProgMap.is_empty !from_prg) then
-    let keys = map_keys !from_prg in
-      errorlabstrm "Program" 
-	(str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
-	   prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
-	   (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++
-	      str "unsolved obligations"))
-
-let input : program_info ProgMap.t -> obj =
-  declare_object
-    { (default_object "Program state") with
-      cache_function = (fun (na, pi) -> from_prg := pi);
-      load_function = (fun _ (_, pi) -> from_prg := pi);
-      discharge_function = (fun _ -> close "section"; None);
-      classify_function = (fun _ -> close "module"; Dispose) }
-    
-open Evd
-
-let progmap_remove prg =
-  Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
-  
-let progmap_add n prg =
-  Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
-
-let progmap_replace prg' = 
-  Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
-
-let rec intset_to = function
-    -1 -> Int.Set.empty
-  | n -> Int.Set.add n (intset_to (pred n))
-
-let subst_body expand prg =
-  let obls, _ = prg.prg_obligations in
-  let ints = intset_to (pred (Array.length obls)) in
-    subst_prog expand obls ints prg
-
-let declare_definition prg =
-  let body, typ = subst_body true prg in
-  let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
-    (Evd.evar_universe_context_subst prg.prg_ctx) in
-  let opaque = prg.prg_opaque in
-  let fix_exn = Stm.get_fix_exn () in
-  let pl, ctx =
-    Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in
-  let ce =
-    definition_entry ~fix_exn
-     ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
-     ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body)
-  in
-  let () = progmap_remove prg in
-  let cst =
-    !declare_definition_ref prg.prg_name 
-     prg.prg_kind ce prg.prg_implicits
-     (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r))
-  in
-  Universes.register_universe_binders cst pl;
-  cst
-      
-open Pp
-
-let rec lam_index n t acc =
-  match kind_of_term t with
-    | Lambda (Name n', _, _) when Id.equal n n' ->
-      acc
-    | Lambda (_, _, b) ->
-	lam_index n b (succ acc)
-    | _ -> raise Not_found
-
-let compute_possible_guardness_evidences (n,_) fixbody fixtype =
-  match n with
-  | Some (loc, n) -> [lam_index n fixbody 0]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      let m = Termops.nb_prod fixtype in
-      let ctx = fst (decompose_prod_n_assum m fixtype) in
-	List.map_i (fun i _ -> i) 0 ctx
-
-let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants)
-
-let declare_mutual_definition l =
-  let len = List.length l in
-  let first = List.hd l in
-  let fixdefs, fixtypes, fiximps =
-    List.split3
-      (List.map (fun x -> 
-	let subs, typ = (subst_body true x) in
-	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
-	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
-	  x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
-  in
-(*   let fixdefs = List.map reduce_fix fixdefs in *)
-  let fixkind = Option.get first.prg_fixkind in
-  let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
-  let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
-  let (local,poly,kind) = first.prg_kind in
-  let fixnames = first.prg_deps in
-  let opaque = first.prg_opaque in
-  let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in
-  let indexes, fixdecls =
-    match fixkind with
-      | IsFixpoint wfl ->
-	  let possible_indexes =
-	    List.map3 compute_possible_guardness_evidences
-              wfl fixdefs fixtypes in
-	  let indexes = 
-              Pretyping.search_guard
-              Loc.ghost (Global.env())
-              possible_indexes fixdecls in
-          Some indexes, 
-          List.map_i (fun i _ ->
-            mk_proof (mkFix ((indexes,i),fixdecls))) 0 l
-      | IsCoFixpoint ->
-          None,
-          List.map_i (fun i _ ->
-            mk_proof (mkCoFix (i,fixdecls))) 0 l
-  in
-  (* Declare the recursive definitions *)
-  let ctx = Evd.evar_context_universe_context first.prg_ctx in
-  let fix_exn = Stm.get_fix_exn () in
-  let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx)
-    fixnames fixdecls fixtypes fiximps in
-    (* Declare notations *)
-    List.iter Metasyntax.add_notation_interpretation first.prg_notations;
-    Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames;
-    let gr = List.hd kns in
-    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
-    Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx;
-    List.iter progmap_remove l; kn
-
-let decompose_lam_prod c ty =
-  let open Context.Rel.Declaration in
-  let rec aux ctx c ty =
-    match kind_of_term c, kind_of_term ty with
-    | LetIn (x, b, t, c), LetIn (x', b', t', ty)
-	 when eq_constr b b' && eq_constr t t' ->
-       let ctx' = Context.Rel.add (LocalDef (x,b',t')) ctx in
-       aux ctx' c ty
-    | _, LetIn (x', b', t', ty) ->
-       let ctx' = Context.Rel.add (LocalDef (x',b',t')) ctx in
-       aux ctx' (lift 1 c) ty
-    | LetIn (x, b, t, c), _ ->
-       let ctx' = Context.Rel.add (LocalDef (x,b,t)) ctx in
-       aux ctx' c (lift 1 ty)
-    | Lambda (x, b, t), Prod (x', b', t')
-       (* By invariant, must be convertible *) ->
-       let ctx' = Context.Rel.add (LocalAssum (x,b')) ctx in
-       aux ctx' t t'
-    | Cast (c, _, _), _ -> aux ctx c ty
-    | _, _ -> ctx, c, ty
-  in aux Context.Rel.empty c ty
-
-let shrink_body c ty =
-  let open Context.Rel.Declaration in
-  let ctx, b, ty =
-    match ty with
-    | None ->
-       let ctx, b = decompose_lam_assum c in
-       ctx, b, None
-    | Some ty ->
-       let ctx, b, ty = decompose_lam_prod c ty in
-       ctx, b, Some ty
-  in
-  let b', ty', n, args =
-    List.fold_left (fun (b, ty, i, args) decl ->
-        if noccurn 1 b && Option.cata (noccurn 1) true ty then
-	  subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args
-	else
-	  let args = if is_local_assum decl then mkRel i :: args else args in
-          mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty,
-	  succ i, args)
-     (b, ty, 1, []) ctx
-  in ctx, b', ty', Array.of_list args
-
-let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst]
-
-let add_hint local prg cst =
-  Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst)
-
-let declare_obligation prg obl body ty uctx =
-  let body = prg.prg_reduce body in
-  let ty = Option.map prg.prg_reduce ty in
-  match obl.obl_status with
-  | _, Evar_kinds.Expand -> false, { obl with obl_body = Some (TermObl body) }
-  | force, Evar_kinds.Define opaque ->
-      let opaque = not force && opaque in
-      let poly = pi2 prg.prg_kind in
-      let ctx, body, ty, args =
-	if get_shrink_obligations () && not poly then
-	  shrink_body body ty else [], body, ty, [||]
-      in
-      let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
-      let ce =
-        { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body;
-          const_entry_secctx = None;
-	  const_entry_type = ty;
-	  const_entry_polymorphic = poly;
-	  const_entry_universes = uctx;
-	  const_entry_opaque = opaque;
-          const_entry_inline_code = false;
-          const_entry_feedback = None;
-      } in
-      (** ppedrot: seems legit to have obligations as local *)
-      let constant = Declare.declare_constant obl.obl_name ~local:true
-	(DefinitionEntry ce,IsProof Property)
-      in
-	if not opaque then add_hint false prg constant;
-	definition_message obl.obl_name;
-	true, { obl with obl_body =
-	    if poly then
-	      Some (DefinedObl constant)
-	    else
-	      Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) }
-
-let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind
-		   notations obls impls kind reduce hook =
-  let obls', b =
-    match b with
-    | None ->
-	assert(Int.equal (Array.length obls) 0);
-	let n = Nameops.add_suffix n "_obligation" in
-	  [| { obl_name = n; obl_body = None;
-	       obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t;
-	       obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty;
-	       obl_tac = None } |],
-	mkVar n
-    | Some b ->
-	Array.mapi
-	  (fun i (n, t, l, o, d, tac) ->
-            { obl_name = n ; obl_body = None; 
-	      obl_location = l; obl_type = t; obl_status = o;
-	      obl_deps = d; obl_tac = tac })
-	  obls, b
-  in
-    { prg_name = n ; prg_body = b; prg_type = reduce t; 
-      prg_ctx = ctx; prg_pl = pl;
-      prg_obligations = (obls', Array.length obls');
-      prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
-      prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; 
-      prg_hook = hook; prg_opaque = opaque;
-      prg_sign = sign }
-
-let map_cardinal m =
-  let i = ref 0 in
-  ProgMap.iter (fun _ v ->
-		if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m;
-  !i
-
-exception Found of program_info
-
-let map_first m =
-  try
-    ProgMap.iter (fun _ v ->
-		  if snd (CEphemeron.get v).prg_obligations > 0 then
-		    raise (Found v)) m;
-    assert(false)
-  with Found x -> x
-
-let get_prog name =
-  let prg_infos = !from_prg in
-    match name with
-	Some n ->
-	  (try get_info (ProgMap.find n prg_infos)
-	   with Not_found -> raise (NoObligations (Some n)))
-      | None ->
-	  (let n = map_cardinal prg_infos in
-	     match n with
-		 0 -> raise (NoObligations None)
-	       | 1 -> get_info (map_first prg_infos)
-	       | _ ->
-                let progs = Id.Set.elements (ProgMap.domain prg_infos) in
-                let prog = List.hd progs in
-                let progs = prlist_with_sep pr_comma Nameops.pr_id progs in
-                errorlabstrm ""
-                  (str "More than one program with unsolved obligations: " ++ progs
-                  ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\""))
-
-let get_any_prog () =
-  let prg_infos = !from_prg in
-  let n = map_cardinal prg_infos in
-  if n > 0 then get_info (map_first prg_infos)
-  else raise (NoObligations None)
-
-let get_prog_err n =
-  try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
-
-let get_any_prog_err () =
-  try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id)
-
-let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0
-
-let all_programs () =
-  ProgMap.fold (fun k p l -> p :: l) !from_prg []
-
-type progress =
-    | Remain of int
-    | Dependent
-    | Defined of global_reference
-
-let obligations_message rem =
-  if rem > 0 then
-    if Int.equal rem 1 then
-      Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining")
-    else
-      Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining")
-  else
-    Flags.if_verbose Feedback.msg_info (str "No more obligations remaining")
-
-let update_obls prg obls rem =
-  let prg' = { prg with prg_obligations = (obls, rem) } in
-    progmap_replace prg';
-    obligations_message rem;
-    if rem > 0 then Remain rem
-    else (
-      match prg'.prg_deps with
-      | [] ->
-	  let kn = declare_definition prg' in
-	    progmap_remove prg';
-	    Defined kn
-      | l ->
-	  let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in
-	    if List.for_all (fun x -> obligations_solved x) progs then
-	      let kn = declare_mutual_definition progs in
-		Defined (ConstRef kn)
-	    else Dependent)
-
-let is_defined obls x = not (Option.is_empty obls.(x).obl_body)
-
-let deps_remaining obls deps =
-  Int.Set.fold
-    (fun x acc ->
-      if is_defined obls x then acc
-      else x :: acc)
-    deps []
-
-let dependencies obls n =
-  let res = ref Int.Set.empty in
-    Array.iteri
-      (fun i obl ->
-	if not (Int.equal i n) && Int.Set.mem n obl.obl_deps then
-	  res := Int.Set.add i !res)
-      obls;
-    !res
-
-let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition
-
-let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma
-
-let kind_of_obligation poly o =
-  match o with
-  | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly
-  | _ -> goal_proof_kind poly
-
-let not_transp_msg =
-  str "Obligation should be transparent but was declared opaque." ++ spc () ++
-    str"Use 'Defined' instead."
-
-let err_not_transp () = pperror not_transp_msg
-
-let rec string_of_list sep f = function
-    [] -> ""
-  | x :: [] -> f x
-  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
-
-(* Solve an obligation using tactics, return the corresponding proof term *)
-
-let solve_by_tac name evi t poly ctx =
-  let id = name in
-  let concl = evi.evar_concl in
-  (* spiwack: the status is dropped. *)
-  let (entry,_,ctx') = Pfedit.build_constant_by_tactic 
-    id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in
-  let env = Global.env () in
-  let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
-  let body, eff = Future.force entry.const_entry_body in
-  assert(Safe_typing.empty_private_constants = eff);
-  let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in
-  Inductiveops.control_only_guard (Global.env ()) (fst body);
-  (fst body), entry.const_entry_type, Evd.evar_universe_context ctx'
-
-let obligation_terminator name num guard hook auto pf =
-  let open Proof_global in
-  let term = Lemmas.universe_proof_terminator guard hook in
-  match pf with
-  | Admitted _ -> apply_terminator term pf
-  | Proved (opq, id, proof) ->
-    if not !shrink_obligations then apply_terminator term pf
-    else
-      let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in
-      let env = Global.env () in
-      let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
-      let ty = entry.Entries.const_entry_type in
-      let (body, cstr), eff = Future.force entry.Entries.const_entry_body in
-      assert(Safe_typing.empty_private_constants = eff);
-      let sigma = Evd.from_ctx (fst uctx) in
-      let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in
-      Inductiveops.control_only_guard (Global.env ()) body;
-      (** Declare the obligation ourselves and drop the hook *)
-      let prg = get_info (ProgMap.find name !from_prg) in
-      let ctx = Evd.evar_universe_context sigma in
-      let prg = { prg with prg_ctx = ctx } in
-      let obls, rem = prg.prg_obligations in
-      let obl = obls.(num) in
-      let status =
-        match obl.obl_status, opq with
-        | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp ()
-        | (true, _), Vernacexpr.Opaque _ -> err_not_transp ()
-        | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true
-        | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false
-        | (_, status), Vernacexpr.Transparent -> status
-      in
-      let obl = { obl with obl_status = false, status } in
-      let uctx = Evd.evar_context_universe_context ctx in
-      let (_, obl) = declare_obligation prg obl body ty uctx in
-      let obls = Array.copy obls in
-      let _ = obls.(num) <- obl in
-      try
-      ignore (update_obls prg obls (pred rem));
-      if pred rem > 0 then
-        begin
-	  let deps = dependencies obls num in
-	  if not (Int.Set.is_empty deps) then
-	    ignore (auto (Some name) None deps)
-	end
-      with e when CErrors.noncritical e ->
-        let e = CErrors.push e in
-        pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
-
-let obligation_hook prg obl num auto ctx' _ gr =
-  let obls, rem = prg.prg_obligations in
-  let cst = match gr with ConstRef cst -> cst | _ -> assert false in
-  let transparent = evaluable_constant cst (Global.env ()) in
-  let () = match obl.obl_status with
-      (true, Evar_kinds.Expand) 
-    | (true, Evar_kinds.Define true) ->
-       if not transparent then err_not_transp ()
-    | _ -> ()
-in
-  let obl = { obl with obl_body = Some (DefinedObl cst) } in
-  let () = if transparent then add_hint true prg cst in
-  let obls = Array.copy obls in
-  let _ = obls.(num) <- obl in
-  let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in
-  let ctx' =
-    if not (pi2 prg.prg_kind) (* Not polymorphic *) then
-      (* The universe context was declared globally, we continue
-         from the new global environment. *)
-      let evd = Evd.from_env (Global.env ()) in
-      let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in
-        Evd.evar_universe_context ctx'
-    else ctx'
-  in
-  let prg = { prg with prg_ctx = ctx' } in
-  let () =
-    try ignore (update_obls prg obls (pred rem))
-    with e when CErrors.noncritical e ->
-      let e = CErrors.push e in
-      pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
-  in
-  if pred rem > 0 then begin
-    let deps = dependencies obls num in
-    if not (Int.Set.is_empty deps) then
-      ignore (auto (Some prg.prg_name) None deps)
-  end
-
-let rec solve_obligation prg num tac =
-  let user_num = succ num in
-  let obls, rem = prg.prg_obligations in
-  let obl = obls.(num) in
-  let remaining = deps_remaining obls obl.obl_deps in
-  let () =
-    if not (Option.is_empty obl.obl_body) then
-      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.");
-    if not (List.is_empty remaining) then
-      pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
-        ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining));
-  in
-  let obl = subst_deps_obl obls obl in
-  let kind = kind_of_obligation (pi2 prg.prg_kind) (snd obl.obl_status) in
-  let evd = Evd.from_ctx prg.prg_ctx in
-  let evd = Evd.update_sigma_env evd (Global.env ()) in
-  let auto n tac oblset = auto_solve_obligations n ~oblset tac in
-  let terminator guard hook =
-    Proof_global.make_terminator
-      (obligation_terminator prg.prg_name num guard hook auto) in
-  let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in
-  let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type ~terminator hook in
-  let _ = Pfedit.by !default_tactic in
-  Option.iter (fun tac -> Pfedit.set_end_tac tac) tac
-
-and obligation (user_num, name, typ) tac =
-  let num = pred user_num in
-  let prg = get_prog_err name in
-  let obls, rem = prg.prg_obligations in
-    if num < Array.length obls then
-      let obl = obls.(num) in
-	match obl.obl_body with
-	    None -> solve_obligation prg num tac
-	  | Some r -> error "Obligation already solved"
-    else error (sprintf "Unknown obligation number %i" (succ num))
-
-
-and solve_obligation_by_tac prg obls i tac =
-  let obl = obls.(i) in
-    match obl.obl_body with
-    | Some _ -> None
-    | None ->
-	try
-	  if List.is_empty (deps_remaining obls obl.obl_deps) then
-	    let obl = subst_deps_obl obls obl in
-	    let tac =
-	      match tac with
-	      | Some t -> t
-	      | None ->
-		  match obl.obl_tac with
-		  | Some t -> t
-		  | None -> !default_tactic
-	    in
-	    let evd = Evd.from_ctx prg.prg_ctx in
-	    let evd = Evd.update_sigma_env evd (Global.env ()) in
-	    let t, ty, ctx =
-	      solve_by_tac obl.obl_name (evar_of_obligation obl) tac
-	        (pi2 prg.prg_kind) (Evd.evar_universe_context evd)
-	    in
-	    let uctx = Evd.evar_context_universe_context ctx in
-	    let prg = {prg with prg_ctx = ctx} in
-	    let def, obl' = declare_obligation prg obl t ty uctx in
-	      obls.(i) <- obl';
-	      if def && not (pi2 prg.prg_kind) then (
-	        (* Declare the term constraints with the first obligation only *)
-	        let evd = Evd.from_env (Global.env ()) in
-	        let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in
-		let ctx' = Evd.evar_universe_context evd in
-		  Some {prg with prg_ctx = ctx'})
-	      else Some prg
-	  else None
-	with e when CErrors.noncritical e ->
-          let (e, _) = CErrors.push e in
-          match e with
-	  | Refiner.FailError (_, s) ->
-	      user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
-          | e -> None (* FIXME really ? *)
-
-and solve_prg_obligations prg ?oblset tac =
-  let obls, rem = prg.prg_obligations in
-  let rem = ref rem in
-  let obls' = Array.copy obls in
-  let set = ref Int.Set.empty in
-  let p = match oblset with
-    | None -> (fun _ -> true)
-    | Some s -> set := s;
-      (fun i -> Int.Set.mem i !set)
-  in
-  let prgref = ref prg in
-  let _ =
-    Array.iteri (fun i x ->
-      if p i then
-        match solve_obligation_by_tac !prgref obls' i tac with
-	| None -> ()
- 	| Some prg' ->
-	   prgref := prg';
-	   let deps = dependencies obls i in
- 	   (set := Int.Set.union !set deps;
- 	    decr rem))
-      obls'
-  in
-    update_obls !prgref obls' !rem
-
-and solve_obligations n tac =
-  let prg = get_prog_err n in
-    solve_prg_obligations prg tac
-
-and solve_all_obligations tac =
-  ProgMap.iter (fun k v -> ignore(solve_prg_obligations (get_info v) tac)) !from_prg
-
-and try_solve_obligation n prg tac =
-  let prg = get_prog prg in
-  let obls, rem = prg.prg_obligations in
-  let obls' = Array.copy obls in
-    match solve_obligation_by_tac prg obls' n tac with
-    | Some prg' -> ignore(update_obls prg' obls' (pred rem))
-    | None -> ()
-
-and try_solve_obligations n tac =
-  try ignore (solve_obligations n tac) with NoObligations _ -> ()
-
-and auto_solve_obligations n ?oblset tac : progress =
-  Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically...");
-  try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
-
-open Pp
-let show_obligations_of_prg ?(msg=true) prg =
-  let n = prg.prg_name in
-  let obls, rem = prg.prg_obligations in
-  let showed = ref 5 in
-    if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: ");
-    Array.iteri (fun i x ->
-		   match x.obl_body with
-		   | None ->
-		       if !showed > 0 then (
-		         decr showed;
-			 let x = subst_deps_obl obls x in
-			 Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
-				   str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++
-				   hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++
-					    str "." ++ fnl ())))
-		   | Some _ -> ())
-      obls
-
-let show_obligations ?(msg=true) n =
-  let progs = match n with
-    | None -> all_programs ()
-    | Some n ->
-	try [ProgMap.find n !from_prg]
-	with Not_found -> raise (NoObligations (Some n))
-  in List.iter (fun x -> show_obligations_of_prg ~msg (get_info x)) progs
-
-let show_term n =
-  let prg = get_prog_err n in
-  let n = prg.prg_name in
-    (Id.print n ++ spc () ++ str":" ++ spc () ++
-	     Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
-	    ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body)
-
-let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
-    ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls =
-  let sign = Decls.initialize_named_context_for_proof () in
-  let info = Id.print n ++ str " has type-checked" in
-  let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in
-  let obls,_ = prg.prg_obligations in
-  if Int.equal (Array.length obls) 0 then (
-    Flags.if_verbose Feedback.msg_info (info ++ str ".");
-    let cst = declare_definition prg in
-      Defined cst)
-  else (
-    let len = Array.length obls in
-    let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in
-      progmap_add n (CEphemeron.create prg);
-      let res = auto_solve_obligations (Some n) tactic in
-	match res with
-	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
-	| _ -> res)
-
-let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
-    ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind =
-  let sign = Decls.initialize_named_context_for_proof () in
-  let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
-    List.iter
-    (fun  (n, b, t, imps, obls) ->
-     let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind)
-       notations obls imps kind reduce hook 
-     in progmap_add n (CEphemeron.create prg)) l;
-    let _defined =
-      List.fold_left (fun finished x ->
-	if finished then finished
-	else
-	  let res = auto_solve_obligations (Some x) tactic in
-	    match res with
-	    | Defined _ -> 
-		(* If one definition is turned into a constant, 
-		   the whole block is defined. *) true
-	    | _ -> false)
-	false deps
-    in ()
-
-let admit_prog prg =
-  let obls, rem = prg.prg_obligations in
-  let obls = Array.copy obls in
-    Array.iteri 
-      (fun i x ->
-        match x.obl_body with
-        | None ->
-            let x = subst_deps_obl obls x in
-	    let ctx = Evd.evar_context_universe_context prg.prg_ctx in
-            let kn = Declare.declare_constant x.obl_name ~local:true
-              (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural)
-            in
-              assumption_message x.obl_name;
-              obls.(i) <- { x with obl_body = Some (DefinedObl kn) }
-        | Some _ -> ())
-      obls;
-    ignore(update_obls prg obls 0)
-
-let rec admit_all_obligations () =
-  let prg = try Some (get_any_prog ()) with NoObligations _ -> None in
-  match prg with
-  | None -> ()
-  | Some prg ->
-    admit_prog prg;
-    admit_all_obligations ()
-
-let admit_obligations n =
-  match n with
-  | None -> admit_all_obligations ()
-  | Some _ ->
-    let prg = get_prog_err n in
-    admit_prog prg
-
-let next_obligation n tac =
-  let prg = match n with
-  | None -> get_any_prog_err ()
-  | Some _ -> get_prog_err n
-  in
-  let obls, rem = prg.prg_obligations in
-  let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in
-  let i = match Array.findi is_open obls with
-  | Some i -> i
-  | None -> anomaly (Pp.str "Could not find a solvable obligation.")
-  in
-  solve_obligation prg i tac
-
-let init_program () =
-  Coqlib.check_required_library Coqlib.datatypes_module_name;
-  Coqlib.check_required_library ["Coq";"Init";"Specif"];
-  Coqlib.check_required_library ["Coq";"Program";"Tactics"]
-
-
-let set_program_mode c =
-  if c then
-    if !Flags.program_mode then ()
-    else begin
-      init_program ();
-      Flags.program_mode := true;
-    end
diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli
deleted file mode 100644
index 69d20696..00000000
--- a/toplevel/obligations.mli
+++ /dev/null
@@ -1,113 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Environ
-open Term
-open Evd
-open Names
-open Pp
-open Globnames
-open Vernacexpr
-open Decl_kinds
-
-(** Forward declaration. *)
-val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t ->
-  Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref
-
-val declare_definition_ref :
-  (Id.t -> definition_kind ->
-     Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits
-       -> global_reference Lemmas.declaration_hook -> global_reference) ref
-
-val check_evars : env -> evar_map -> unit
-
-val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t
-val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list
-
-(* env, id, evars, number of function prototypes to try to clear from
-   evars contexts, object and type *)
-val eterm_obligations : env -> Id.t -> evar_map -> int ->
-  ?status:Evar_kinds.obligation_definition_status -> constr -> types ->
-  (Id.t * types * Evar_kinds.t Loc.located *
-     (bool * Evar_kinds.obligation_definition_status) * Int.Set.t *
-      unit Proofview.tactic option) array
-    (* Existential key, obl. name, type as product, 
-       location of the original evar, associated tactic,
-       status and dependencies as indexes into the array *)
-  * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) *
-    constr * types
-    (* Translations from existential identifiers to obligation identifiers 
-       and for terms with existentials to closed terms, given a 
-       translation from obligation identifiers to constrs, new term, new type *)
-
-type obligation_info =
-  (Id.t * Term.types * Evar_kinds.t Loc.located *
-      (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array
-    (* ident, type, location, (opaque or transparent, expand or define),
-       dependencies, tactic to solve it *)
-
-type progress = (* Resolution status of a program *)
-  | Remain of int  (* n obligations remaining *)
-  | Dependent (* Dependent on other definitions *)
-  | Defined of global_reference (* Defined as id *)
-
-val default_tactic : unit Proofview.tactic ref
-
-val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> 
-  Evd.evar_universe_context ->
-  ?pl:(Id.t Loc.located list) -> (* Universe binders *)
-  ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?tactic:unit Proofview.tactic ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress
-
-type notations =
-    (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
-
-type fixpoint_kind =
-  | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
-  | IsCoFixpoint
-
-val add_mutual_definitions :
-  (Names.Id.t * Term.constr * Term.types *
-      (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
-  Evd.evar_universe_context ->
-  ?pl:(Id.t Loc.located list) -> (* Universe binders *)
-  ?tactic:unit Proofview.tactic ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool ->
-  notations ->
-  fixpoint_kind -> unit
-
-val obligation : int * Names.Id.t option * Constrexpr.constr_expr option ->
-  Tacexpr.raw_tactic_expr option -> unit
-
-val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit
-
-val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress
-(* Number of remaining obligations to be solved for this program *)
-
-val solve_all_obligations : unit Proofview.tactic option -> unit
-
-val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit
-
-val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit
-
-val show_obligations : ?msg:bool -> Names.Id.t option -> unit
-
-val show_term : Names.Id.t option -> std_ppcmds
-
-val admit_obligations : Names.Id.t option -> unit
-
-exception NoObligations of Names.Id.t option
-
-val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds
-
-val set_program_mode : bool -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
deleted file mode 100644
index ef09f6fa..00000000
--- a/toplevel/record.ml
+++ /dev/null
@@ -1,579 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Globnames
-open Nameops
-open Term
-open Vars
-open Environ
-open Declarations
-open Entries
-open Declare
-open Constrintern
-open Decl_kinds
-open Type_errors
-open Constrexpr
-open Constrexpr_ops
-open Goptions
-open Sigma.Notations
-open Context.Rel.Declaration
-
-(********** definition d'un record (structure) **************)
-
-(** Flag governing use of primitive projections. Disabled by default. *)
-let primitive_flag = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "use of primitive projections";
-      optkey   = ["Primitive";"Projections"];
-      optread  = (fun () -> !primitive_flag) ;
-      optwrite = (fun b -> primitive_flag := b) }
-
-let typeclasses_strict = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "strict typeclass resolution";
-      optkey   = ["Typeclasses";"Strict";"Resolution"];
-      optread  = (fun () -> !typeclasses_strict);
-      optwrite = (fun b -> typeclasses_strict := b); }
-
-let typeclasses_unique = ref false
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "unique typeclass instances";
-      optkey   = ["Typeclasses";"Unique";"Instances"];
-      optread  = (fun () -> !typeclasses_unique);
-      optwrite = (fun b -> typeclasses_unique := b); }
-
-let interp_fields_evars env evars impls_env nots l =
-  List.fold_left2
-    (fun (env, uimpls, params, impls) no ((loc, i), b, t) ->
-      let t', impl = interp_type_evars_impls env evars ~impls t in
-      let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in
-      let impls =
-	match i with
-	| Anonymous -> impls
-	| Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls
-      in
-      let d = match b' with
-	      | None -> LocalAssum (i,t')
-	      | Some b' -> LocalDef (i,b',t')
-      in
-      List.iter (Metasyntax.set_notation_for_interpretation impls) no;
-      (push_rel d env, impl :: uimpls, d::params, impls))
-    (env, [], [], impls_env) nots l
-
-let compute_constructor_level evars env l =
-  List.fold_right (fun d (env, univ) ->
-    let univ = 
-      if is_local_assum d then
-	let s = Retyping.get_sort_of env evars (get_type d) in
-	  Univ.sup (univ_of_sort s) univ 
-      else univ
-    in (push_rel d env, univ)) 
-    l (env, Univ.type0m_univ)
-
-let binder_of_decl = function
-  | Vernacexpr.AssumExpr(n,t) -> (n,None,t)
-  | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None))
-
-let binders_of_decls = List.map binder_of_decl
-
-let typecheck_params_and_fields def id pl t ps nots fs =
-  let env0 = Global.env () in
-  let ctx = Evd.make_evar_universe_context env0 pl in
-  let evars = ref (Evd.from_ctx ctx) in
-  let _ = 
-    let error bk (loc, name) = 
-      match bk, name with
-      | Default _, Anonymous ->
-        user_err_loc (loc, "record", str "Record parameters must be named")
-      | _ -> ()
-    in
-      List.iter 
-	(function LocalRawDef (b, _) -> error default_binder_kind b
-	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls
-           | LocalPattern _ -> assert false) ps
-  in 
-  let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in
-  let t', template = match t with 
-    | Some t -> 
-       let env = push_rel_context newps env0 in
-       let poly =
-         match t with
-         | CSort (_, Misctypes.GType []) -> true | _ -> false in
-       let s = interp_type_evars env evars ~impls:empty_internalization_env t in
-       let sred = Reductionops.whd_all env !evars s in
-	 (match kind_of_term sred with
-	 | Sort s' -> 
-	    (if poly then
-               match Evd.is_sort_variable !evars s' with
-	       | Some l -> evars := Evd.make_flexible_variable !evars true l; 
-	                  sred, true
-	       | None -> s, false
-             else s, false)
-	 | _ -> user_err_loc (constr_loc t,"", str"Sort expected."))
-    | None -> 
-      let uvarkind = Evd.univ_flexible_alg in
-	mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true
-  in
-  let fullarity = it_mkProd_or_LetIn t' newps in
-  let env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in
-  let env2,impls,newfs,data =
-    interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs)
-  in
-  let sigma = 
-    Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars (Evd.empty,!evars) in
-  let evars, nf = Evarutil.nf_evars_and_universes sigma in
-  let arity = nf t' in
-  let arity, evars = 
-    let _, univ = compute_constructor_level evars env_ar newfs in
-    let ctx, aritysort = Reduction.dest_arity env0 arity in
-      assert(List.is_empty ctx); (* Ensured by above analysis *)
-      if not def && (Sorts.is_prop aritysort || 
-	(Sorts.is_set aritysort && is_impredicative_set env0)) then
-	arity, evars
-      else
-	let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in
-	if Univ.is_small_univ univ &&
-	   Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then
-	   (* We can assume that the level in aritysort is not constrained
-	       and clear it, if it is flexible *)
-	  mkArity (ctx, Sorts.sort_of_univ univ),
-	  Evd.set_eq_sort env_ar evars (Prop Pos) aritysort
-	else arity, evars
-  in
-  let evars, nf = Evarutil.nf_evars_and_universes evars in
-  let newps = Context.Rel.map nf newps in
-  let newfs = Context.Rel.map nf newfs in
-  let ce t = Pretyping.check_evars env0 Evd.empty evars t in
-    List.iter (iter_constr ce) (List.rev newps);
-    List.iter (iter_constr ce) (List.rev newfs);
-    Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs
-
-let degenerate_decl decl =
-  let id = match get_name decl with
-    | Name id -> id
-    | Anonymous -> anomaly (Pp.str "Unnamed record variable") in
-  match decl with
-    | LocalAssum (_,t) -> (id, LocalAssumEntry t)
-    | LocalDef (_,b,_) -> (id, LocalDefEntry b)
-
-type record_error =
-  | MissingProj of Id.t * Id.t list
-  | BadTypedProj of Id.t * env * Type_errors.type_error
-
-let warn_cannot_define_projection =
-  CWarnings.create ~name:"cannot-define-projection" ~category:"records"
-         (fun msg -> hov 0 msg)
-
-(* If a projection is not definable, we throw an error if the user
-asked it to be a coercion. Otherwise, we just print an info
-message. The user might still want to name the field of the record. *)
-let warning_or_error coe indsp err =
-  let st = match err with
-    | MissingProj (fi,projs) ->
-	let s,have = if List.length projs > 1 then "s","were" else "","was" in
-        (pr_id fi ++
-	   strbrk" cannot be defined because the projection" ++ str s ++ spc () ++
-           prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++
-	   strbrk " not defined.")
-    | BadTypedProj (fi,ctx,te) ->
-	match te with
-	  | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) ->
-              (pr_id fi ++
-		strbrk" cannot be defined because it is informative and " ++
-		Printer.pr_inductive (Global.env()) indsp ++
-		strbrk " is not.")
-	  | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) ->
-	      (pr_id fi ++
-		strbrk" cannot be defined because it is large and " ++
-		Printer.pr_inductive (Global.env()) indsp ++
-		strbrk " is not.")
-	  | _ ->
-              (pr_id fi ++ strbrk " cannot be defined because it is not typable.")
-  in
-  if coe then errorlabstrm "structure" st;
-  Flags.if_verbose Feedback.msg_info (hov 0 st)
-
-type field_status =
-  | NoProjection of Name.t
-  | Projection of constr
-
-exception NotDefinable of record_error
-
-(* This replaces previous projection bodies in current projection *)
-(* Undefined projs are collected and, at least one undefined proj occurs *)
-(* in the body of current projection then the latter can not be defined *)
-(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *)
-(* [[fields]] defined in ctxt [[params;x:ind]] *)
-let subst_projection fid l c =
-  let lv = List.length l in
-  let bad_projs = ref [] in
-  let rec substrec depth c = match kind_of_term c with
-    | Rel k ->
-	(* We are in context [[params;fields;x:ind;...depth...]] *)
-        if k <= depth+1 then
-	  c
-        else if k-depth-1 <= lv then
-	  match List.nth l (k-depth-2) with
-	    | Projection t -> lift depth t
-	    | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
-	    | NoProjection Anonymous ->
-                errorlabstrm "" (str "Field " ++ pr_id fid ++
-                  str " depends on the " ++ pr_nth (k-depth-1) ++ str
-                  " field which has no name.")
-        else
-	  mkRel (k-lv)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in
-  let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
-  let c'' = substrec 0 c' in
-  if not (List.is_empty !bad_projs) then
-    raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
-  c''
-
-let instantiate_possibly_recursive_type indu paramdecls fields =
-  let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in
-  Termops.substl_rel_context (subst@[mkIndU indu]) fields
-
-let warn_non_primitive_record =
-  CWarnings.create ~name:"non-primitive-record" ~category:"record"
-         (fun (env,indsp) ->
-          (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ 
-                    strbrk" could not be defined as a primitive record")))
-
-(* We build projections *)
-let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields =
-  let env = Global.env() in
-  let (mib,mip) = Global.lookup_inductive indsp in
-  let u = Declareops.inductive_instance mib in
-  let paramdecls = Inductive.inductive_paramdecls (mib, u) in
-  let poly = mib.mind_polymorphic in
-  let ctx = Univ.instantiate_univ_context mib.mind_universes in
-  let indu = indsp, u in
-  let r = mkIndU (indsp,u) in
-  let rp = applist (r, Context.Rel.to_extended_list 0 paramdecls) in
-  let paramargs = Context.Rel.to_extended_list 1 paramdecls in (*def in [[params;x:rp]]*)
-  let x = Name binder_name in
-  let fields = instantiate_possibly_recursive_type indu paramdecls fields in
-  let lifted_fields = Termops.lift_rel_context 1 fields in
-  let primitive = 
-    if !primitive_flag then 
-      let is_primitive = 
-	match mib.mind_record with
-	| Some (Some _) -> true
-	| Some None | None -> false
-      in
-	if not is_primitive then 
-	  warn_non_primitive_record (env,indsp);
-	is_primitive
-    else false
-  in
-  let (_,_,kinds,sp_projs,_) =
-    List.fold_left3
-      (fun (nfi,i,kinds,sp_projs,subst) coe decl impls ->
-        let fi = get_name decl in
-        let ti = get_type decl in
-	let (sp_projs,i,subst) =
-	  match fi with
-	  | Anonymous ->
-	      (None::sp_projs,i,NoProjection fi::subst)
-	  | Name fid -> try
-	    let kn, term = 
-	      if is_local_assum decl && primitive then
-		(** Already defined in the kernel silently *)
-		let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in
-		  Declare.definition_message fid;
-		  kn, mkProj (Projection.make kn false,mkRel 1)
-	      else
-		let ccl = subst_projection fid subst ti in
-		let body = match decl with
-		  | LocalDef (_,ci,_) -> subst_projection fid subst ci
-		  | LocalAssum _ ->
-	            (* [ccl] is defined in context [params;x:rp] *)
-		    (* [ccl'] is defined in context [params;x:rp;x:rp] *)
-		    let ccl' = liftn 1 2 ccl in
-		    let p = mkLambda (x, lift 1 rp, ccl') in
-		    let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
-		    let ci = Inductiveops.make_case_info env indsp LetStyle in
-		      mkCase (ci, p, mkRel 1, [|branch|]) 
-		in
-		let proj =
-	          it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
-		let projtyp =
-                  it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
-	        try
-		  let entry = {
-		    const_entry_body =
-		      Future.from_val (Safe_typing.mk_pure_proof proj);
-		    const_entry_secctx = None;
-		    const_entry_type = Some projtyp;
-		    const_entry_polymorphic = poly;
-		    const_entry_universes =
-		      if poly then ctx else Univ.UContext.empty;
-		    const_entry_opaque = false;
-		    const_entry_inline_code = false;
-		    const_entry_feedback = None } in
-		  let k = (DefinitionEntry entry,IsDefinition kind) in
-		  let kn = declare_constant ~internal:InternalTacticRequest fid k in
-		  let constr_fip =
-		    let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
-		      applist (mkConstU (kn,u),proj_args) 
-		  in
-		    Declare.definition_message fid;
-		    kn, constr_fip
-                with Type_errors.TypeError (ctx,te) ->
-                  raise (NotDefinable (BadTypedProj (fid,ctx,te))) 
-	    in
-	    let refi = ConstRef kn in
-	    Impargs.maybe_declare_manual_implicits false refi impls;
-	    if coe then begin
-	      let cl = Class.class_of_global (IndRef indsp) in
-	        Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl
-	    end;
-	    let i = if is_local_assum decl then i+1 else i in
-	      (Some kn::sp_projs, i, Projection term::subst)
-            with NotDefinable why ->
-	      warning_or_error coe indsp why;
-	      (None::sp_projs,i,NoProjection fi::subst) in
-      (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst))
-      (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls)
-  in (kinds,sp_projs)
-
-let structure_signature ctx =
-  let rec deps_to_evar evm l =
-    match l with [] -> Evd.empty
-      | [decl] ->
-        let env = Environ.empty_named_context_val in
-        let evm = Sigma.Unsafe.of_evar_map evm in
-        let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
-        let evm = Sigma.to_evar_map evm in
-        evm
-      | decl::tl ->
-          let env = Environ.empty_named_context_val in
-          let evm = Sigma.Unsafe.of_evar_map evm in
-          let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
-          let evm = Sigma.to_evar_map evm in
-	  let new_tl = Util.List.map_i
-	    (fun pos decl ->
-	       map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in
-	  deps_to_evar evm new_tl in
-  deps_to_evar Evd.empty (List.rev ctx)
-
-open Typeclasses
-
-let declare_structure finite poly ctx id idbuild paramimpls params arity template 
-    fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign =
-  let nparams = List.length params and nfields = List.length fields in
-  let args = Context.Rel.to_extended_list nfields params in
-  let ind = applist (mkRel (1+nparams+nfields), args) in
-  let type_constructor = it_mkProd_or_LetIn ind fields in
-  let binder_name = 
-    match name with
-    | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) 
-    | Some n -> n
-  in
-  let mie_ind =
-    { mind_entry_typename = id;
-      mind_entry_arity = arity;
-      mind_entry_template = not poly && template;
-      mind_entry_consnames = [idbuild];
-      mind_entry_lc = [type_constructor] }
-  in
-  let mie =
-    { mind_entry_params = List.map degenerate_decl params;
-      mind_entry_record = Some (if !primitive_flag then Some binder_name else None);
-      mind_entry_finite = finite;
-      mind_entry_inds = [mie_ind];
-      mind_entry_polymorphic = poly;
-      mind_entry_private = None;
-      mind_entry_universes = ctx;
-    }
-  in
-  let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in
-  let rsp = (kn,0) in (* This is ind path of idstruc *)
-  let cstr = (rsp,1) in
-  let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in
-  let build = ConstructRef cstr in
-  let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in
-  Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs);
-  rsp
-
-let implicits_of_context ctx =
-  List.map_i (fun i name ->
-    let explname =
-      match name with
-      | Name n -> Some n
-      | Anonymous -> None
-    in ExplByPos (i, explname), (true, true, true))
-    1 (List.rev (Anonymous :: (List.map get_name ctx)))
-
-let declare_class finite def poly ctx id idbuild paramimpls params arity 
-    template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign =
-  let fieldimpls =
-    (* Make the class implicit in the projections, and the params if applicable. *)
-    let len = List.length params in
-    let impls = implicits_of_context params in
-      List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls
-  in
-  let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in
-  let impl, projs =
-    match fields with
-    | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def ->
-      let class_body = it_mkLambda_or_LetIn field params in
-      let class_type = it_mkProd_or_LetIn arity params in
-      let class_entry = 
-	Declare.definition_entry ~types:class_type ~poly ~univs:ctx class_body in
-      let cst = Declare.declare_constant (snd id)
-	(DefinitionEntry class_entry, IsDefinition Definition)
-      in
-      let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in
-      let inst_type = appvectc (mkConstU cstu)
-			       (Termops.rel_vect 0 (List.length params)) in
-      let proj_type =
-	it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in
-      let proj_body =
-	it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in
-      let proj_entry =
-	Declare.definition_entry ~types:proj_type ~poly
-	    ~univs:(if poly then ctx else Univ.UContext.empty) proj_body
-      in
-      let proj_cst = Declare.declare_constant proj_name
-        (DefinitionEntry proj_entry, IsDefinition Definition)
-      in
-      let cref = ConstRef cst in
-      Impargs.declare_manual_implicits false cref [paramimpls];
-      Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls];
-      Classes.set_typeclass_transparency (EvalConstRef cst) false false;
-      let sub = match List.hd coers with
-	| Some b -> Some ((if b then Backward else Forward), List.hd priorities) 
-	| None -> None 
-      in
-      cref, [Name proj_name, sub, Some proj_cst]
-    | _ ->
-       let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls
-	  params arity template fieldimpls fields
-	  ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign
-       in
-       let coers = List.map2 (fun coe pri -> 
-			      Option.map (fun b -> 
-			      if b then Backward, pri else Forward, pri) coe)
-	  coers priorities
-       in
-       let l = List.map3 (fun decl b y -> get_name decl, b, y)
-         (List.rev fields) coers (Recordops.lookup_projections ind)
-       in IndRef ind, l
-  in
-  let ctx_context =
-    List.map (fun decl ->
-      match Typeclasses.class_of_constr (get_type decl) with
-      | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true)
-      | None -> None)
-      params, params
-  in
-  let k =
-    { cl_impl = impl;
-      cl_strict = !typeclasses_strict;
-      cl_unique = !typeclasses_unique;
-      cl_context = ctx_context;
-      cl_props = fields;
-      cl_projs = projs }
-  in
-    add_class k; impl
-
-
-let add_constant_class cst =
-  let ty = Universes.unsafe_type_of_global (ConstRef cst) in
-  let ctx, arity = decompose_prod_assum ty in
-  let tc = 
-    { cl_impl = ConstRef cst;
-      cl_context = (List.map (const None) ctx, ctx);
-      cl_props = [LocalAssum (Anonymous, arity)];
-      cl_projs = [];
-      cl_strict = !typeclasses_strict;
-      cl_unique = !typeclasses_unique
-    }
-  in add_class tc;
-    set_typeclass_transparency (EvalConstRef cst) false false
-      
-let add_inductive_class ind =
-  let mind, oneind = Global.lookup_inductive ind in
-  let k =
-    let ctx = oneind.mind_arity_ctxt in
-    let inst = Univ.UContext.instance mind.mind_universes in
-    let ty = Inductive.type_of_inductive
-      (push_rel_context ctx (Global.env ()))
-      ((mind,oneind),inst)
-    in
-      { cl_impl = IndRef ind;
-	cl_context = List.map (const None) ctx, ctx;
-	cl_props = [LocalAssum (Anonymous, ty)];
-	cl_projs = [];
-	cl_strict = !typeclasses_strict;
-	cl_unique = !typeclasses_unique }
-  in add_class k
-
-let declare_existing_class g =
-  match g with
-  | ConstRef x -> add_constant_class x
-  | IndRef x -> add_inductive_class x
-  | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class", 
-		      Pp.str"Unsupported class type, only constants and inductives are allowed")
-
-open Vernacexpr
-
-(* [fs] corresponds to fields and [ps] to parameters; [coers] is a
-   list telling if the corresponding fields must me declared as coercions 
-   or subinstances. *)
-let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) =
-  let cfs,notations = List.split cfs in
-  let cfs,priorities = List.split cfs in
-  let coers,fs = List.split cfs in
-  let extract_name acc = function
-      Vernacexpr.AssumExpr((_,Name id),_) -> id::acc
-    | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc
-    | _ -> acc in
-  let allnames =  idstruc::(List.fold_left extract_name [] fs) in
-  if not (List.distinct_f Id.compare allnames)
-  then error "Two objects have the same name";
-  let isnot_class = match kind with Class false -> false | _ -> true in
-  if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then
-    error "Priorities only allowed for type class substructures";
-  (* Now, younger decl in params and fields is on top *)
-  let (pl, ctx), arity, template, implpars, params, implfs, fields =
-    States.with_state_protection (fun () ->
-      typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in
-  let sign = structure_signature (fields@params) in
-  let gr = match kind with
-  | Class def ->
-     let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in
-     let gr = declare_class finite def poly ctx (loc,idstruc) idbuild
-	  implpars params arity template implfs fields is_coe coers priorities sign in
-	gr
-    | _ ->
-	let implfs = List.map
-	  (fun impls -> implpars @ Impargs.lift_implicits
-	    (succ (List.length params)) impls) implfs in
-	let ind = declare_structure finite poly ctx idstruc
-	  idbuild implpars params arity template implfs 
-	  fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in
-	IndRef ind
-  in
-  Universes.register_universe_binders gr pl;
-  gr
diff --git a/toplevel/record.mli b/toplevel/record.mli
deleted file mode 100644
index c50e5778..00000000
--- a/toplevel/record.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-open Vernacexpr
-open Constrexpr
-open Impargs
-open Globnames
-
-val primitive_flag : bool ref
-
-(** [declare_projections ref name coers params fields] declare projections of
-   record [ref] (if allowed) using the given [name] as argument, and put them
-   as coercions accordingly to [coers]; it returns the absolute names of projections *)
-
-val declare_projections :
-  inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t ->
-  coercion_flag list -> manual_explicitation list list -> Context.Rel.t ->
-  (Name.t * bool) list * constant option list
-
-val declare_structure :
-  Decl_kinds.recursivity_kind ->
-  bool (** polymorphic?*) -> Univ.universe_context ->
-  Id.t -> Id.t ->
-  manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *)
-  bool (** template arity ? *) ->
-  Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *)
-  ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t ->
-  bool -> (** coercion? *)
-  bool list -> (** field coercions *)
-  Evd.evar_map ->
-  inductive
-
-val definition_structure :
-  inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind *
-  plident with_coercion * local_binder list *
-  (local_decl_expr with_instance with_priority with_notation) list *
-  Id.t * constr_expr option -> global_reference
-
-val declare_existing_class : global_reference -> unit
diff --git a/toplevel/search.ml b/toplevel/search.ml
deleted file mode 100644
index ff3c7a4f..00000000
--- a/toplevel/search.ml
+++ /dev/null
@@ -1,315 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Term
-open Declarations
-open Libobject
-open Environ
-open Pattern
-open Printer
-open Libnames
-open Globnames
-open Nametab
-open Goptions
-
-type filter_function = global_reference -> env -> constr -> bool
-type display_function = global_reference -> env -> constr -> unit
-
-(* This option restricts the output of [SearchPattern ...],
-[SearchAbout ...], etc. to the names of the symbols matching the
-query, separated by a newline. This type of output is useful for
-editors (like emacs), to generate a list of completion candidates
-without having to parse thorugh the types of all symbols. *)
-
-type glob_search_about_item =
-  | GlobSearchSubPattern of constr_pattern
-  | GlobSearchString of string
-
-module SearchBlacklist =
-  Goptions.MakeStringTable
-    (struct
-      let key = ["Search";"Blacklist"]
-      let title = "Current search blacklist : "
-      let member_message s b =
-	str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s
-      let synchronous = true
-     end)
-
-(* The functions iter_constructors and iter_declarations implement the behavior
-   needed for the Coq searching commands.
-   These functions take as first argument the procedure
-   that will be called to treat each entry.  This procedure receives the name
-   of the object, the assumptions that will make it possible to print its type,
-   and the constr term that represent its type. *)
-
-let iter_constructors indsp u fn env nconstr =
-  for i = 1 to nconstr do
-    let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in
-    fn (ConstructRef (indsp, i)) env typ
-  done
-
-let iter_named_context_name_type f =
-  let open Context.Named.Declaration in
-  List.iter (fun decl -> f (get_id decl) (get_type decl))
-
-(* General search over hypothesis of a goal *)
-let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
-  let env = Global.env () in
-  let iter_hyp idh typ = fn (VarRef idh) env typ in
-  let evmap,e = Pfedit.get_goal_context glnum in
-  let pfctxt = named_context e in
-  iter_named_context_name_type iter_hyp pfctxt
-
-(* General search over declarations *)
-let iter_declarations (fn : global_reference -> env -> constr -> unit) =
-  let open Context.Named.Declaration in
-  let env = Global.env () in
-  let iter_obj (sp, kn) lobj = match object_tag lobj with
-  | "VARIABLE" ->
-    begin try
-      let decl = Global.lookup_named (basename sp) in
-      fn (VarRef (get_id decl)) env (get_type decl)
-    with Not_found -> (* we are in a section *) () end
-  | "CONSTANT" ->
-    let cst = Global.constant_of_delta_kn kn in
-    let gr = ConstRef cst in
-    let typ = Global.type_of_global_unsafe gr in
-      fn gr env typ
-  | "INDUCTIVE" ->
-    let mind = Global.mind_of_delta_kn kn in
-    let mib = Global.lookup_mind mind in
-    let iter_packet i mip =
-      let ind = (mind, i) in
-      let u = Declareops.inductive_instance mib in
-      let i = (ind, u) in
-      let typ = Inductiveops.type_of_inductive env i in
-      let () = fn (IndRef ind) env typ in
-      let len = Array.length mip.mind_user_lc in
-      iter_constructors ind u fn env len
-    in
-    Array.iteri iter_packet mib.mind_packets
-  | _ -> ()
-  in
-  try Declaremods.iter_all_segments iter_obj
-  with Not_found -> ()
-
-let generic_search glnumopt fn =
-  (match glnumopt with
-  | None -> ()
-  | Some glnum ->  iter_hypothesis glnum fn);
-  iter_declarations fn
-
-(** Filters *)
-
-(** This function tries to see whether the conclusion matches a pattern. *)
-(** FIXME: this is quite dummy, we may find a more efficient algorithm. *)
-let rec pattern_filter pat ref env typ =
-  let typ = strip_outer_cast typ in
-  if Constr_matching.is_matching env Evd.empty pat typ then true
-  else match kind_of_term typ with
-  | Prod (_, _, typ)
-  | LetIn (_, _, _, typ) -> pattern_filter pat ref env typ
-  | _ -> false
-
-let rec head_filter pat ref env typ =
-  let typ = strip_outer_cast typ in
-  if Constr_matching.is_matching_head env Evd.empty pat typ then true
-  else match kind_of_term typ with
-  | Prod (_, _, typ)
-  | LetIn (_, _, _, typ) -> head_filter pat ref env typ
-  | _ -> false
-
-let full_name_of_reference ref =
-  let (dir,id) = repr_path (path_of_global ref) in
-  DirPath.to_string dir ^ "." ^ Id.to_string id
-
-(** Whether a reference is blacklisted *)
-let blacklist_filter_aux () =
-  let l = SearchBlacklist.elements () in
-  fun ref env typ ->
-  let name = full_name_of_reference ref in
-  let is_not_bl str = not (String.string_contains ~where:name ~what:str) in
-  List.for_all is_not_bl l
-
-let module_filter (mods, outside) ref env typ =
-  let sp = path_of_global ref in
-  let sl = dirpath sp in
-  let is_outside md = not (is_dirpath_prefix_of md sl) in
-  let is_inside md = is_dirpath_prefix_of md sl in
-  if outside then List.for_all is_outside mods
-  else List.is_empty mods || List.exists is_inside mods
-
-let name_of_reference ref = Id.to_string (basename_of_global ref)
-
-let search_about_filter query gr env typ = match query with
-| GlobSearchSubPattern pat ->
-  Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat typ
-| GlobSearchString s ->
-  String.string_contains ~where:(name_of_reference gr) ~what:s
-
-
-(** SearchPattern *)
-
-let search_pattern gopt pat mods pr_search =
-  let blacklist_filter = blacklist_filter_aux () in
-  let filter ref env typ =
-    module_filter mods ref env typ &&
-    pattern_filter pat ref env typ &&
-    blacklist_filter ref env typ
-  in
-  let iter ref env typ =
-    if filter ref env typ then pr_search ref env typ
-  in
-  generic_search gopt iter
-
-(** SearchRewrite *)
-
-let eq = Coqlib.glob_eq
-
-let rewrite_pat1 pat =
-  PApp (PRef eq, [| PMeta None; pat; PMeta None |])
-
-let rewrite_pat2 pat =
-  PApp (PRef eq, [| PMeta None; PMeta None; pat |])
-
-let search_rewrite gopt pat mods pr_search =
-  let pat1 = rewrite_pat1 pat in
-  let pat2 = rewrite_pat2 pat in
-  let blacklist_filter = blacklist_filter_aux () in
-  let filter ref env typ =
-    module_filter mods ref env typ &&
-    (pattern_filter pat1 ref env typ ||
-       pattern_filter pat2 ref env typ) &&
-    blacklist_filter ref env typ
-  in
-  let iter ref env typ =
-    if filter ref env typ then pr_search ref env typ
-  in
-  generic_search gopt iter
-
-(** Search *)
-
-let search_by_head gopt pat mods pr_search =
-  let blacklist_filter = blacklist_filter_aux () in
-  let filter ref env typ =
-    module_filter mods ref env typ &&
-    head_filter pat ref env typ &&
-    blacklist_filter ref env typ
-  in
-  let iter ref env typ =
-    if filter ref env typ then pr_search ref env typ
-  in
-  generic_search gopt iter
-
-(** SearchAbout *)
-
-let search_about gopt items mods pr_search =
-  let blacklist_filter = blacklist_filter_aux () in
-  let filter ref env typ =
-    let eqb b1 b2 = if b1 then b2 else not b2 in
-    module_filter mods ref env typ &&
-    List.for_all
-      (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items &&
-    blacklist_filter ref env typ
-  in
-  let iter ref env typ =
-    if filter ref env typ then pr_search ref env typ
-  in
-  generic_search gopt iter
-
-type search_constraint =
-  | Name_Pattern of Str.regexp
-  | Type_Pattern of Pattern.constr_pattern
-  | SubType_Pattern of Pattern.constr_pattern
-  | In_Module of Names.DirPath.t
-  | Include_Blacklist
-
-type 'a coq_object = {
-  coq_object_prefix : string list;
-  coq_object_qualid : string list;
-  coq_object_object : 'a;
-}
-
-let interface_search =
-  let rec extract_flags name tpe subtpe mods blacklist = function
-  | [] -> (name, tpe, subtpe, mods, blacklist)
-  | (Name_Pattern regexp, b) :: l ->
-    extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
-  | (Type_Pattern pat, b) :: l ->
-    extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
-  | (SubType_Pattern pat, b) :: l ->
-    extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
-  | (In_Module id, b) :: l ->
-    extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
-  | (Include_Blacklist, b) :: l ->
-    extract_flags name tpe subtpe mods b l
-  in
-  fun ?glnum flags ->
-  let (name, tpe, subtpe, mods, blacklist) =
-    extract_flags [] [] [] [] false flags
-  in
-  let blacklist_filter = blacklist_filter_aux () in
-  let filter_function ref env constr =
-    let id = Names.Id.to_string (Nametab.basename_of_global ref) in
-    let path = Libnames.dirpath (Nametab.path_of_global ref) in
-    let toggle x b = if x then b else not b in
-    let match_name (regexp, flag) =
-      toggle (Str.string_match regexp id 0) flag
-    in
-    let match_type (pat, flag) =
-      toggle (Constr_matching.is_matching env Evd.empty pat constr) flag
-    in
-    let match_subtype (pat, flag) =
-      toggle
-        (Constr_matching.is_matching_appsubterm ~closed:false 
-	   env Evd.empty pat constr) flag
-    in
-    let match_module (mdl, flag) =
-      toggle (Libnames.is_dirpath_prefix_of mdl path) flag
-    in
-    List.for_all match_name name &&
-    List.for_all match_type tpe &&
-    List.for_all match_subtype subtpe &&
-    List.for_all match_module mods &&
-    (blacklist || blacklist_filter ref env constr)
-  in
-  let ans = ref [] in
-  let print_function ref env constr =
-    let fullpath = DirPath.repr (Nametab.dirpath_of_global ref) in
-    let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in
-    let (shortpath, basename) = Libnames.repr_qualid qualid in
-    let shortpath = DirPath.repr shortpath in
-    (* [shortpath] is a suffix of [fullpath] and we're looking for the missing
-       prefix *)
-    let rec prefix full short accu = match full, short with
-    | _, [] ->
-      let full = List.rev_map Id.to_string full in
-      (full, accu)
-    | _ :: full, m :: short ->
-      prefix full short (Id.to_string m :: accu)
-    | _ -> assert false
-    in
-    let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in
-    let answer = {
-      coq_object_prefix = prefix;
-      coq_object_qualid = qualid;
-      coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr);
-    } in
-    ans := answer :: !ans;
-  in
-  let iter ref env typ =
-    if filter_function ref env typ then print_function ref env typ
-  in
-  let () = generic_search glnum iter in
-  !ans
-
-let blacklist_filter ref env typ =
-  blacklist_filter_aux () ref env typ
diff --git a/toplevel/search.mli b/toplevel/search.mli
deleted file mode 100644
index ba3d48ef..00000000
--- a/toplevel/search.mli
+++ /dev/null
@@ -1,76 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Names
-open Term
-open Environ
-open Pattern
-open Globnames
-
-(** {6 Search facilities. } *)
-
-type glob_search_about_item =
-  | GlobSearchSubPattern of constr_pattern
-  | GlobSearchString of string
-
-type filter_function = global_reference -> env -> constr -> bool
-type display_function = global_reference -> env -> constr -> unit
-
-(** {6 Generic filter functions} *)
-
-val blacklist_filter : filter_function
-(** Check whether a reference is blacklisted. *)
-
-val module_filter : DirPath.t list * bool -> filter_function
-(** Check whether a reference pertains or not to a set of modules *)
-
-val search_about_filter : glob_search_about_item -> filter_function
-(** Check whether a reference matches a SearchAbout query. *)
-
-(** {6 Specialized search functions}
-
-[search_xxx gl pattern modinout] searches the hypothesis of the [gl]th
-goal and the global environment for things matching [pattern] and
-satisfying module exclude/include clauses of [modinout]. *)
-
-val search_by_head : int option -> constr_pattern -> DirPath.t list * bool
-                  -> display_function -> unit
-val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool
-                  -> display_function -> unit
-val search_pattern : int option -> constr_pattern -> DirPath.t list * bool
-                  -> display_function -> unit
-val search_about   : int option -> (bool * glob_search_about_item) list
-                  -> DirPath.t list * bool -> display_function -> unit
-
-type search_constraint =
-  (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
-  | Name_Pattern of Str.regexp
-  (** Whether the object type satisfies a pattern *)
-  | Type_Pattern of Pattern.constr_pattern
-  (** Whether some subtype of object type satisfies a pattern *)
-  | SubType_Pattern of Pattern.constr_pattern
-  (** Whether the object pertains to a module *)
-  | In_Module of Names.DirPath.t
-  (** Bypass the Search blacklist *)
-  | Include_Blacklist
-
-type 'a coq_object = {
-  coq_object_prefix : string list;
-  coq_object_qualid : string list;
-  coq_object_object : 'a;
-}
-
-val interface_search : ?glnum:int -> (search_constraint * bool) list ->
-  string coq_object list
-
-(** {6 Generic search function} *)
-
-val generic_search : int option -> display_function -> unit
-(** This function iterates over all hypothesis of the goal numbered
-    [glnum] (if present) and all known declarations. *)
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index d6892236..9fb2e33d 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,21 +1,6 @@
-Himsg
-ExplainErr
-Class
-Locality
-Metasyntax
-Auto_ind_decl
-Search
-Indschemes
-Obligations
-Command
-Classes
-Record
-Assumptions
-Vernacinterp
-Mltop
-Vernacentries
 Vernac
 Usage
 Coqloop
 Coqinit
+Coqargs
 Coqtop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 38ceacf5..504ffa52 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -1,9 +1,11 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 let version ret =
@@ -30,7 +32,7 @@ let print_usage_channel co command =
 \n  -R dir coqdir          recursively map physical dir to logical coqdir\
 \n  -Q dir coqdir          map physical dir to logical coqdir\
 \n  -top coqdir            set the toplevel name to be coqdir instead of Top\
-\n  -notop                 set the toplevel name to be the empty logical path\
+\n  -coqlib dir            set the coq standard library directory\
 \n  -exclude-dir f         exclude subdirectories named f for option -R\
 \n\
 \n  -noinit                start without loading the Init library\
@@ -56,7 +58,8 @@ let print_usage_channel co command =
 \n\
 \n  -where                 print Coq's standard library location and exit\
 \n  -config, --config      print Coq's configuration information and exit\
-\n  -v                     print Coq version and exit\
+\n  -v, --version          print Coq version and exit\
+\n  -print-version         print Coq version in easy to parse format and exit\
 \n  -list-tags             print highlight color tags known by Coq and exit\
 \n\
 \n  -quiet                 unset display of extra information (implies -w \"-all\")\
@@ -69,22 +72,20 @@ let print_usage_channel co command =
 \n  -boot                  boot mode (implies -q and -batch)\
 \n  -bt                    print backtraces (requires configure debug flag)\
 \n  -debug                 debug mode (implies -bt)\
+\n  -stm-debug             STM debug mode (will trace every transaction) \
 \n  -emacs                 tells Coq it is executed under Emacs\
 \n  -noglob                do not dump globalizations\
 \n  -dump-glob f           dump globalizations in file f (to be used by coqdoc)\
-\n  -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\
 \n  -impredicative-set     set sort Set impredicative\
 \n  -indices-matter        levels of indices (and nonuniform parameters) contribute to the level of inductives\
 \n  -type-in-type          disable universe consistency checking\
-\n  -xml                   export XML files either to the hierarchy rooted in\
-\n                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to\
-\n                         stdout (if unset)\
+\n  -mangle-names x        mangle auto-generated names using prefix x\
 \n  -time                  display the time taken by each command\
 \n  -profile-ltac          display the time taken by each (sub)tactic\
 \n  -m, --memory           display total heap size at program exit\
 \n                         (use environment variable\
 \n                          OCAML_GC_STATS=\"/tmp/gclog.txt\"\
-\n                          for full Gc stats dump)
+\n                          for full Gc stats dump)\
 \n  -native-compiler       precompile files for the native_compute machinery\
 \n  -h, -help, --help      print this list of options\
 \n";
@@ -115,16 +116,3 @@ let print_usage_coqc () =
   flush stderr ;
   exit 1
 
-(* Print the configuration information *)
-
-let print_config () =
-  if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n";
-  Printf.printf "COQLIB=%s/\n" (Envars.coqlib ());
-  Printf.printf "DOCDIR=%s/\n" (Envars.docdir ());
-  Printf.printf "OCAMLFIND=%s\n" (Envars.ocamlfind ());
-  Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
-  Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o;
-  Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
-  Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ());
-  Printf.printf "CAMLP4OPTIONS=%s\n" Coq_config.camlp4compat;
-  Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false")
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index dccb40e7..fbb0117d 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -1,9 +1,11 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 (** {6 Prints the version number on the standard output and exits (with 0). } *)
@@ -21,5 +23,3 @@ val add_to_usage : string -> string -> unit
 val print_usage_coqtop : unit -> unit
 val print_usage_coqc : unit -> unit
 
-(** {6 Prints the configuration information } *)
-val print_config : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index bfdae85d..fdd0d4ed 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -1,9 +1,11 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 (* Parsing of vernacular. *)
@@ -11,165 +13,48 @@
 open Pp
 open CErrors
 open Util
-open Flags
 open Vernacexpr
+open Vernacprop
 
 (* The functions in this module may raise (unexplainable!) exceptions.
    Use the module Coqtoplevel, which catches these exceptions
    (the exceptions are explained only at the toplevel). *)
 
-let user_error loc s = CErrors.user_err_loc (loc,"_",str s)
-
-(* Navigation commands are allowed in a coqtop session but not in a .v file *)
-
-let rec is_navigation_vernac = function
-  | VernacResetInitial
-  | VernacResetName _
-  | VernacBacktrack _
-  | VernacBackTo _
-  | VernacBack _
-  | VernacStm _ -> true
-  | VernacRedirect (_, (_,c))
-  | VernacTime (_,c) ->
-      is_navigation_vernac c (* Time Back* is harmless *)
-  | c -> is_deep_navigation_vernac c
-
-and is_deep_navigation_vernac = function
-  | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c
-  | _ -> false
-
-(* NB: Reset is now allowed again as asked by A. Chlipala *)
-
-let is_reset = function
-  | VernacResetInitial | VernacResetName _ -> true
-  | _ -> false
-
-let checknav_simple loc cmd =
+let checknav_simple {CAst.loc;v=cmd} =
   if is_navigation_vernac cmd && not (is_reset cmd) then
-    user_error loc "Navigation commands forbidden in files."
+    CErrors.user_err ?loc (str "Navigation commands forbidden in files.")
 
-let checknav_deep loc ast =
+let checknav_deep {CAst.loc;v=ast} =
   if is_deep_navigation_vernac ast then
-    user_error loc "Navigation commands forbidden in nested commands."
-
-(* When doing Load on a file, two behaviors are possible:
-
-   - either the history stack is grown by only one command,
-     the "Load" itself. This is mandatory for command-counting
-     interfaces (CoqIDE).
-
-   - either each individual sub-commands in the file is added
-     to the history stack. This allows commands like Show Script
-     to work across the loaded file boundary (cf. bug #2820).
-
-   The best of the two could probably be combined someday,
-   in the meanwhile we use a flag. *)
-
-let atomic_load = ref true
-
-let _ =
-  Goptions.declare_bool_option
-    { Goptions.optsync  = true;
-      Goptions.optdepr  = false;
-      Goptions.optname  = "atomic registration of commands in a Load";
-      Goptions.optkey   = ["Atomic";"Load"];
-      Goptions.optread  = (fun () -> !atomic_load);
-      Goptions.optwrite = ((:=) atomic_load) }
+    CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.")
 
 let disable_drop = function
-  | Drop -> CErrors.error "Drop is forbidden."
+  | Drop -> CErrors.user_err Pp.(str "Drop is forbidden.")
   | e -> e
 
-(* Opening and closing a channel. Open it twice when verbose: the first
-   channel is used to read the commands, and the second one to print them.
-   Note: we could use only one thanks to seek_in, but seeking on and on in
-   the file we parse seems a bit risky to me.  B.B.  *)
-
-let open_file_twice_if verbosely longfname =
-  let in_chan = open_utf8_file_in longfname in
-  let verb_ch =
-    if verbosely then Some (open_utf8_file_in longfname) else None in
-  let po = Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in
-  (in_chan, longfname, (po, verb_ch))
-
-let close_input in_chan (_,verb) =
-  try
-    close_in in_chan;
-    match verb with
-      | Some verb_ch -> close_in verb_ch
-      | _ -> ()
-  with e when CErrors.noncritical e -> ()
-
-let verbose_phrase verbch loc =
-  let loc = Loc.unloc loc in
-  match verbch with
-    | Some ch ->
-	let len = snd loc - fst loc in
-	let s = String.create len in
-        seek_in ch (fst loc);
-        really_input ch s 0 len;
-        Feedback.msg_notice (str s)
-    | None -> ()
-
-exception End_of_input
-
-let parse_sentence = Flags.with_option Flags.we_are_parsing
-  (fun (po, verbch) ->
-  match Pcoq.Gram.entry_parse Pcoq.main_entry po with
-    | Some (loc,_ as com) -> verbose_phrase verbch loc; com
-    | None -> raise End_of_input)
-
-(* vernac parses the given stream, executes interpfun on the syntax tree it
- * parses, and is verbose on "primitives" commands if verbosely is true *)
-
-let chan_beautify = ref stdout
-let beautify_suffix = ".beautified"
-
-let set_formatter_translator ch =
-  let out s b e = output ch s b e in
-  Format.set_formatter_output_functions out (fun () -> flush ch);
-  Format.set_max_boxes max_int
-
-let pr_new_syntax_in_context loc chan_beautify ocom =
-  let loc = Loc.unloc loc in
-  if !beautify_file then set_formatter_translator chan_beautify;
-  let fs = States.freeze ~marshallable:`No in
-  (* The content of this is not supposed to fail, but if ever *)
-  try
-    (* Side-effect: order matters *)
-    let before = comment (CLexer.extract_comments (fst loc)) in
-    let com = match ocom with
-      | Some com -> Ppvernac.pr_vernac com
-      | None -> mt() in
-    let after = comment (CLexer.extract_comments (snd loc)) in
-    if !beautify_file then
-      Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after))
-    else
-      Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
-    States.unfreeze fs;
-    Format.set_formatter_out_channel stdout
-  with any ->
-    States.unfreeze fs;
-    Format.set_formatter_out_channel stdout
-
-let pr_new_syntax po loc chan_beautify ocom =
-  (* Reinstall the context of parsing which includes the bindings of comments to locations *)
-  Pcoq.Gram.with_parsable po (pr_new_syntax_in_context chan_beautify loc) ocom
+(* Echo from a buffer based on position.
+   XXX: Should move to utility file. *)
+let vernac_echo ?loc in_chan = let open Loc in
+  Option.iter (fun loc ->
+      let len = loc.ep - loc.bp in
+      seek_in in_chan loc.bp;
+      Feedback.msg_notice @@ str @@ really_input_string in_chan len
+    ) loc
 
 (* For coqtop -time, we display the position in the file,
    and a glimpse of the executed command *)
 
-let pp_cmd_header loc com =
-  let shorten s = try (String.sub s 0 30)^"..." with _ -> s in
-  let noblank s =
-    for i = 0 to String.length s - 1 do
-      match s.[i] with
-	| ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~'
-	| _ -> ()
-    done;
-    s
+let pp_cmd_header {CAst.loc;v=com} =
+  let shorten s =
+    if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s
   in
-  let (start,stop) = Loc.unloc loc in
+  let noblank s = String.map (fun c ->
+      match c with
+	| ' ' | '\n' | '\t' | '\r' -> '~'
+	| x -> x
+      ) s
+  in
+  let (start,stop) = Option.cata Loc.unloc (0,0) loc in
   let safe_pr_vernac x =
     try Ppvernac.pr_vernac x
     with e -> str (Printexc.to_string e) in
@@ -180,173 +65,164 @@ let pp_cmd_header loc com =
 (* This is a special case where we assume we are in console batch mode
    and take control of the console.
  *)
-let print_cmd_header loc com =
-  Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com);
-  Format.pp_print_flush !Pp_control.std_ft ()
+let print_cmd_header com =
+  Pp.pp_with !Topfmt.std_ft (pp_cmd_header com);
+  Format.pp_print_flush !Topfmt.std_ft ()
 
-let rec interp_vernac po chan_beautify checknav (loc,com) =
-  let interp = function
-    | VernacLoad (verbosely, fname) ->
-	let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
-        let fname = CUnix.make_suffix fname ".v" in
-        let f = Loadpath.locate_file fname in
-        load_vernac verbosely f
+(* Reenable when we get back to feedback printing *)
+(* let is_end_of_input any = match any with *)
+(*     Stm.End_of_input -> true *)
+(*   | _ -> false *)
 
-    | v -> Stm.interp (Flags.is_verbose()) (loc,v)
-  in
+module State = struct
+
+  type t = {
+    doc : Stm.doc;
+    sid : Stateid.t;
+    proof : Proof.t option;
+  }
+
+end
+
+let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) =
+  let open State in
     try
-      checknav loc com;
-      if !beautify then pr_new_syntax po chan_beautify loc (Some com);
-      (* XXX: This is not 100% correct if called from an IDE context *)
-      if !Flags.time then print_cmd_header loc com;
-      let com = if !Flags.time then VernacTime (loc,com) else com in
-      interp com
+      (* The -time option is only supported from console-based clients
+         due to the way it prints. *)
+      if time then print_cmd_header com;
+      let com = if time then CAst.make ?loc @@ VernacTime(time,com) else com in
+      let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in
+
+      (* Main STM interaction *)
+      if ntip <> `NewTip then
+        anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!");
+
+      (* Due to bug #5363 we cannot use observe here as we should,
+         it otherwise reveals bugs *)
+      (* Stm.observe nsid; *)
+      let ndoc = if check then Stm.finish ~doc else doc in
+      let new_proof = Proof_global.give_me_the_proof_opt () in
+      { doc = ndoc; sid = nsid; proof = new_proof }
     with reraise ->
+      (* XXX: In non-interactive mode edit_at seems to do very weird
+         things, so we better avoid it while we investigate *)
+      if interactive then ignore(Stm.edit_at ~doc:state.doc state.sid);
       let (reraise, info) = CErrors.push reraise in
-      let loc' = Option.default Loc.ghost (Loc.get_loc info) in
-      if Loc.is_ghost loc' then iraise (reraise, Loc.add_loc info loc)
-      else iraise (reraise, info)
+      let info = begin
+        match Loc.get_loc info with
+        | None   -> Option.cata (Loc.add_loc info) info loc
+        | Some _ -> info
+      end in iraise (reraise, info)
 
 (* Load a vernac file. CErrors are annotated with file and location *)
-and load_vernac verbosely file =
-  let chan_beautify =
-    if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in
-  let (in_chan, fname, input) = open_file_twice_if verbosely file in
+let load_vernac_core ~time ~echo ~check ~interactive ~state file =
+  (* Keep in sync *)
+  let in_chan = open_utf8_file_in file in
+  let in_echo = if echo then Some (open_utf8_file_in file) else None in
+  let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in
+
+  let in_pa   = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in
+  let rstate  = ref state in
+  (* For beautify, list of parsed sids *)
+  let rids    = ref [] in
+  let open State in
   try
     (* we go out of the following infinite loop when a End_of_input is
      * raised, which means that we raised the end of the file being loaded *)
     while true do
-      let loc_ast = Flags.silently parse_sentence input in
-      CWarnings.set_current_loc (fst loc_ast);
-      Flags.silently (interp_vernac (fst input) chan_beautify checknav_simple) loc_ast;
-    done
+      let { CAst.loc; _ } as ast =
+          Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa
+        (* If an error in parsing occurs, we propagate the exception
+           so the caller of load_vernac will take care of it. However,
+           in the future it could be possible that we want to handle
+           all the errors as feedback events, thus in this case we
+           should relay the exception here for convenience. A
+           possibility is shown below, however we may want to refactor
+           this code:
+
+        try Stm.parse_sentence !rsid in_pa
+        with
+        | any when not is_end_of_input any ->
+          let (e, info) = CErrors.push any in
+          let loc = Loc.get_loc info in
+          let msg = CErrors.iprint (e, info) in
+          Feedback.msg_error ?loc msg;
+          iraise (e, info)
+       *)
+      in
+      (* Printing of vernacs *)
+      Option.iter (vernac_echo ?loc) in_echo;
+
+      checknav_simple ast;
+      let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) ast in
+      rids := state.sid :: !rids;
+      rstate := state;
+    done;
+    input_cleanup ();
+    !rstate, !rids, Pcoq.Gram.comment_state in_pa
   with any ->   (* whatever the exception *)
     let (e, info) = CErrors.push any in
-    close_input in_chan input;    (* we must close the file first *)
+    input_cleanup ();
     match e with
-      | End_of_input ->
-          if !beautify then
-            pr_new_syntax (fst input) chan_beautify (Loc.make_loc (max_int,max_int)) None;
-          if !Flags.beautify_file then close_out chan_beautify;
-      | reraise ->
-         if !Flags.beautify_file then close_out chan_beautify;
-	 iraise (disable_drop e, info)
-
-(** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit]
-   It executes one vernacular command. By default the command is
-   considered as non-state-preserving, in which case we add it to the
-   Backtrack stack (triggering a save of a frozen state and the generation
-   of a new state label). An example of state-preserving command is one coming
-   from the query panel of Coqide. *)
-
-let process_expr po loc_ast = interp_vernac po stdout checknav_deep loc_ast
-
-(* XML output hooks *)
-let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore ()
-let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore ()
+    | Stm.End_of_input -> !rstate, !rids, Pcoq.Gram.comment_state in_pa
+    | reraise -> iraise (disable_drop e, info)
 
-let warn_file_no_extension =
-  CWarnings.create ~name:"file-no-extension" ~category:"filesystem"
-         (fun (f,ext) ->
-          str "File \"" ++ str f ++
-            strbrk "\" has been implicitly expanded to \"" ++
-            str f ++ str ext ++ str "\"")
+let process_expr ~time ~state loc_ast =
+  checknav_deep loc_ast;
+  interp_vernac ~time ~interactive:true ~check:true ~state loc_ast
 
-let ensure_ext ext f =
-  if Filename.check_suffix f ext then f
-  else begin
-    warn_file_no_extension (f,ext);
-    f ^ ext
-  end
+(******************************************************************************)
+(* Beautify-specific code                                                     *)
+(******************************************************************************)
 
-let chop_extension f =
-  try Filename.chop_extension f with _ -> f
-
-let ensure_bname src tgt =
-  let src, tgt = Filename.basename src, Filename.basename tgt in
-  let src, tgt = chop_extension src, chop_extension tgt in
-  if src <> tgt then begin
-    Feedback.msg_error (str "Source and target file names must coincide, directories can differ");
-    Feedback.msg_error (str "Source: " ++ str src);
-    Feedback.msg_error (str "Target: " ++ str tgt);
-    flush_all ();
-    exit 1
-  end
-
-let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt
-
-let ensure_v v = ensure ".v" v v
-let ensure_vo v vo = ensure ".vo" v vo
-let ensure_vio v vio = ensure ".vio" v vio
-
-let ensure_exists f =
-  if not (Sys.file_exists f) then begin
-    Feedback.msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f));
-    exit 1
-  end
-
-(* Compile a vernac file *)
-let compile verbosely f =
-  let check_pending_proofs () =
-    let pfs = Pfedit.get_all_proof_names () in
-    if not (List.is_empty pfs) then
-      (Feedback.msg_error (str "There are pending proofs"); flush_all (); exit 1) in
-  match !Flags.compilation_mode with
-  | BuildVo ->
-      let long_f_dot_v = ensure_v f in
-      ensure_exists long_f_dot_v;
-      let long_f_dot_vo =
-        match !Flags.compilation_output_name with
-        | None -> long_f_dot_v ^ "o"
-        | Some f -> ensure_vo long_f_dot_v f in
-      let ldir = Flags.verbosely Library.start_library long_f_dot_vo in
-      Stm.set_compilation_hints long_f_dot_vo;
-      Aux_file.(start_aux_file
-        ~aux_file:(aux_file_name_for long_f_dot_vo)
-        ~v_file:long_f_dot_v);
-      Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
-      Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
-      if !Flags.xml_export then Hook.get f_xml_start_library ();
-      let wall_clock1 = Unix.gettimeofday () in
-      let _ = load_vernac verbosely long_f_dot_v in
-      Stm.join ();
-      let wall_clock2 = Unix.gettimeofday () in
-      check_pending_proofs ();
-      Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ());
-      Aux_file.record_in_aux_at Loc.ghost "vo_compile_time"
-        (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
-      Aux_file.stop_aux_file ();
-      if !Flags.xml_export then Hook.get f_xml_end_library ();
-      Dumpglob.end_dump_glob ()
-  | BuildVio ->
-      let long_f_dot_v = ensure_v f in
-      ensure_exists long_f_dot_v;
-      let long_f_dot_vio =
-        match !Flags.compilation_output_name with
-        | None -> long_f_dot_v ^ "io"
-        | Some f -> ensure_vio long_f_dot_v f in
-      let ldir = Flags.verbosely Library.start_library long_f_dot_vio in
-      Dumpglob.noglob ();
-      Stm.set_compilation_hints long_f_dot_vio;
-      let _ = load_vernac verbosely long_f_dot_v in
-      Stm.finish ();
-      check_pending_proofs ();
-      Stm.snapshot_vio ldir long_f_dot_vio;
-      Stm.reset_task_queue ()
-  | Vio2Vo ->
-      let open Filename in
-      let open Library in
-      Dumpglob.noglob ();
-      let f = if check_suffix f ".vio" then chop_extension f else f in
-      let lfdv, sum, lib, univs, disch, tasks, proofs = load_library_todo f in
-      Stm.set_compilation_hints lfdv;
-      let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
-      Library.save_library_raw lfdv sum lib univs proofs
-
-let compile v f = 
-  ignore(CoqworkmgrApi.get 1);
-  compile v f;
-  CoqworkmgrApi.giveback 1
+(* vernac parses the given stream, executes interpfun on the syntax tree it
+ * parses, and is verbose on "primitives" commands if verbosely is true *)
+let beautify_suffix = ".beautified"
 
-let () = Hook.set Stm.process_error_hook
-  ExplainErr.process_vernac_interp_error
+let set_formatter_translator ch =
+  let out s b e = output_substring ch s b e in
+  let ft = Format.make_formatter out (fun () -> flush ch) in
+  Format.pp_set_max_boxes ft max_int;
+  ft
+
+let pr_new_syntax ?loc ft_beautify ocom =
+  let loc = Option.cata Loc.unloc (0,0) loc in
+  let before = comment (Pputils.extract_comments (fst loc)) in
+  let com = Option.cata Ppvernac.pr_vernac (mt ()) ocom in
+  let after = comment (Pputils.extract_comments (snd loc)) in
+  if !Flags.beautify_file then
+    (Pp.pp_with ft_beautify (hov 0 (before ++ com ++ after));
+     Format.pp_print_flush ft_beautify ())
+  else
+    Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)))
+
+(* load_vernac with beautify *)
+let beautify_pass ~doc ~comments ~ids ~filename =
+  let ft_beautify, close_beautify =
+    if !Flags.beautify_file then
+      let chan_beautify = open_out (filename^beautify_suffix) in
+      set_formatter_translator chan_beautify, fun () -> close_out chan_beautify;
+    else
+      !Topfmt.std_ft, fun () -> ()
+  in
+  (* The interface to the comment printer is imperative, so we first
+     set the comments, then we call print. This has to be done for
+     each file. *)
+  Pputils.beautify_comments := comments;
+  List.iter (fun id ->
+      Option.iter (fun (loc,ast) ->
+          pr_new_syntax ?loc ft_beautify (Some ast))
+        (Stm.get_ast ~doc id)) ids;
+
+  (* Is this called so comments at EOF are printed? *)
+  pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) ft_beautify None;
+  close_beautify ()
+
+(* Main driver for file loading. For now, we only do one beautify
+   pass. *)
+let load_vernac ~time ~echo ~check ~interactive ~state filename =
+  let ostate, ids, comments = load_vernac_core ~time ~echo ~check ~interactive ~state filename in
+  (* Pass for beautify *)
+  if !Flags.beautify then beautify_pass ~doc:ostate.State.doc ~comments ~ids:List.(rev ids) ~filename;
+  (* End pass *)
+  ostate
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 0d9f5871..51758642 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -1,37 +1,32 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 (** Parsing of vernacular. *)
-
-(** Read a vernac command on the specified input (parse only).
-   Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
-
-val parse_sentence : Pcoq.Gram.coq_parsable * in_channel option ->
- Loc.t * Vernacexpr.vernac_expr
-
-(** Reads and executes vernac commands from a stream. *)
-
-exception End_of_input
-
-val process_expr : Pcoq.Gram.coq_parsable -> Loc.t * Vernacexpr.vernac_expr -> unit
-
-(** Set XML hooks *)
-val xml_start_library : (unit -> unit) Hook.t
-val xml_end_library   : (unit -> unit) Hook.t
-
-(** Load a vernac file, verbosely or not. Errors are annotated with file
-   and location *)
-
-val load_vernac : bool -> string -> unit
-
-
-(** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
-
-val compile : bool -> string -> unit
-
-val is_navigation_vernac : Vernacexpr.vernac_expr -> bool
+module State : sig
+
+  type t = {
+    doc : Stm.doc;
+    sid : Stateid.t;
+    proof : Proof.t option;
+  }
+
+end
+
+(** [process_expr sid cmd] Executes vernac command [cmd]. Callers are
+    expected to handle and print errors in form of exceptions, however
+    care is taken so the state machine is left in a consistent
+    state. *)
+val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t
+
+(** [load_vernac echo sid file] Loads [file] on top of [sid], will
+    echo the commands if [echo] is set. Callers are expected to handle
+    and print errors in form of exceptions. *)
+val load_vernac : time:bool -> echo:bool -> check:bool -> interactive:bool ->
+  state:State.t -> string -> State.t
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
deleted file mode 100644
index 41ee165f..00000000
--- a/toplevel/vernacentries.ml
+++ /dev/null
@@ -1,2257 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Concrete syntax of the mathematical vernacular MV V2.6 *)
-
-open Pp
-open CErrors
-open Util
-open Flags
-open Names
-open Nameops
-open Term
-open Pfedit
-open Tacmach
-open Constrintern
-open Prettyp
-open Printer
-open Command
-open Goptions
-open Libnames
-open Globnames
-open Vernacexpr
-open Decl_kinds
-open Constrexpr
-open Redexpr
-open Lemmas
-open Misctypes
-open Locality
-open Sigma.Notations
-
-(** TODO: make this function independent of Ltac *)
-let (f_interp_redexp, interp_redexp_hook) = Hook.make ()
-
-let debug = false
-let prerr_endline x =
-  if debug then prerr_endline (x ()) else ()
-
-(* Misc *)
-
-let cl_of_qualid = function
-  | FunClass -> Classops.CL_FUN
-  | SortClass -> Classops.CL_SORT
-  | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r)
-
-let scope_class_of_qualid qid =
-  Notation.scope_class_of_class (cl_of_qualid qid)
-
-(*******************)
-(* "Show" commands *)
-
-let show_proof () =
-  (* spiwack: this would probably be cooler with a bit of polishing. *)
-  let p = Proof_global.give_me_the_proof () in
-  let pprf = Proof.partial_proof p in
-  Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
-
-let show_node () =
-  (* spiwack: I'm have little clue what this function used to do. I deactivated it, 
-      could, possibly, be cleaned away. (Feb. 2010) *)
-  ()
-
-let show_thesis () =
-     Feedback.msg_error (anomaly (Pp.str "TODO") )
-
-let show_top_evars () =
-  (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
-  let pfts = get_pftreestate () in
-  let gls = Proof.V82.subgoals pfts in
-  let sigma = gls.Evd.sigma in
-  Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma))
-
-let show_universes () =
-  let pfts = get_pftreestate () in
-  let gls = Proof.V82.subgoals pfts in
-  let sigma = gls.Evd.sigma in
-  let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in
-    Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma));
-    Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx)
-
-let show_prooftree () =
-  (* Spiwack: proof tree is currently not working *)
-  ()
-
-let enable_goal_printing = ref true
-
-let print_subgoals () =
-  if !enable_goal_printing && is_verbose ()
-  then begin
-    Feedback.msg_notice (pr_open_subgoals ())
-  end
-
-let try_print_subgoals () =
-  try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()
-
-
-  (* Simulate the Intro(s) tactic *)
-
-let show_intro all =
-  let pf = get_pftreestate() in
-  let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
-  if not (List.is_empty gls) then begin
-    let gl = {Evd.it=List.hd gls ; sigma = sigma; } in
-    let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
-    if all then
-      let lid = Tactics.find_intro_names l gl in
-      Feedback.msg_notice (hov 0 (prlist_with_sep  spc pr_id lid))
-    else if not (List.is_empty l) then
-      let n = List.last l in
-      Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
-  end
-
-(** Prepare a "match" template for a given inductive type.
-    For each branch of the match, we list the constructor name
-    followed by enough pattern variables.
-    [Not_found] is raised if the given string isn't the qualid of
-    a known inductive type. *)
-
-let make_cases_aux glob_ref =
-  match glob_ref with
-    | Globnames.IndRef i ->
-	let {Declarations.mind_nparams = np}
-	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr }
-	      = Global.lookup_inductive i in
-	Util.Array.fold_right2
-	  (fun consname typ l ->
-	     let al = List.rev (fst (decompose_prod typ)) in
-	     let al = Util.List.skipn np al in
-	     let rec rename avoid = function
-	       | [] -> []
-	       | (n,_)::l ->
-		   let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in
-		   Id.to_string n' :: rename (n'::avoid) l in
-	     let al' = rename [] al in
-	     (Id.to_string consname :: al') :: l)
-	  carr tarr []
-    | _ -> raise Not_found
-
-let make_cases s =
-  let qualified_name = Libnames.qualid_of_string s in
-  let glob_ref = Nametab.locate qualified_name in
-  make_cases_aux glob_ref
-
-(** Textual display of a generic "match" template *)
-
-let show_match id =
-  let patterns =
-    try make_cases_aux (Nametab.global id)
-    with Not_found -> error "Unknown inductive type."
-  in
-  let pr_branch l =
-    str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>"
-  in
-  Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++
-	    prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ()))
-
-(* "Print" commands *)
-
-let print_path_entry p =
-  let dir = pr_dirpath (Loadpath.logical p) in
-  let path = str (Loadpath.physical p) in
-  (dir ++ str " " ++ tbrk (0, 0) ++ path)
-
-let print_loadpath dir =
-  let l = Loadpath.get_load_paths () in
-  let l = match dir with
-  | None -> l
-  | Some dir ->
-    let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in
-    List.filter filter l
-  in
-  Pp.t (str "Logical Path:                 " ++
-                tab () ++ str "Physical path:" ++ fnl () ++
-                prlist_with_sep fnl print_path_entry l)
-
-let print_modules () =
-  let opened = Library.opened_libraries ()
-  and loaded = Library.loaded_libraries () in
-  (* we intersect over opened to preserve the order of opened since *)
-  (* non-commutative operations (e.g. visibility) are done at import time *)
-  let loaded_opened = List.intersect DirPath.equal opened loaded
-  and only_loaded = List.subtract DirPath.equal loaded opened in
-  str"Loaded and imported library files: " ++
-  pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
-  str"Loaded and not imported library files: " ++
-  pr_vertical_list pr_dirpath only_loaded
-
-
-let print_module r =
-  let (loc,qid) = qualid_of_reference r in
-  try
-    let globdir = Nametab.locate_dir qid in
-      match globdir with
-	  DirModule (dirpath,(mp,_)) ->
-	    Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp)
-	| _ -> raise Not_found
-  with
-      Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid)
-
-let print_modtype r =
-  let (loc,qid) = qualid_of_reference r in
-  try
-    let kn = Nametab.locate_modtype qid in
-    Feedback.msg_notice (Printmod.print_modtype kn)
-  with Not_found ->
-    (* Is there a module of this name ? If yes we display its type *)
-    try
-      let mp = Nametab.locate_module qid in
-      Feedback.msg_notice (Printmod.print_module false mp)
-    with Not_found ->
-      Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid)
-
-let print_namespace ns =
-  let ns = List.rev (Names.DirPath.repr ns) in
-  (* [match_dirpath], [match_modulpath] are helpers for [matches]
-     which checks whether a constant is in the namespace [ns]. *)
-  let rec match_dirpath ns = function
-    | [] -> Some ns
-    | id::dir ->
-        begin match match_dirpath ns dir with
-        | Some [] as y -> y
-        | Some (a::ns') ->
-            if Names.Id.equal a id then Some ns'
-            else None
-        | None -> None
-        end
-  in
-  let rec match_modulepath ns = function
-    | MPbound _ -> None (* Not a proper namespace. *)
-    | MPfile dir -> match_dirpath ns (Names.DirPath.repr dir)
-    | MPdot (mp,lbl) ->
-        let id = Names.Label.to_id lbl in
-        begin match match_modulepath ns mp with
-        | Some [] as y -> y
-        | Some (a::ns') ->
-            if Names.Id.equal a id then Some ns'
-            else None
-        | None -> None
-        end
-  in
-  (* [qualified_minus n mp] returns a list of qualifiers representing
-     [mp] except the [n] first (in the concrete syntax order).  The
-     idea is that if [mp] matches [ns], then [qualified_minus mp
-     (length ns)] will be the correct representation of [mp] assuming
-     [ns] is imported. *)
-  (* precondition: [mp] matches some namespace of length [n] *)
-  let qualified_minus n mp =
-    let rec list_of_modulepath = function
-      | MPbound _ -> assert false (* MPbound never matches *)
-      | MPfile dir -> Names.DirPath.repr dir
-      | MPdot (mp,lbl) -> (Names.Label.to_id lbl)::(list_of_modulepath mp)
-    in
-    snd (Util.List.chop n (List.rev (list_of_modulepath mp)))
-  in
-  let print_list pr l = prlist_with_sep (fun () -> str".") pr l in
-  let print_kn kn =
-    (* spiwack: I'm ignoring the dirpath, is that bad? *)
-    let (mp,_,lbl) = Names.repr_kn kn in
-    let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in
-    print_list pr_id qn
-  in
-  let print_constant k body =
-    (* FIXME: universes *)
-    let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in
-    print_kn k ++ str":" ++ spc() ++ Printer.pr_type t
-  in
-  let matches mp = match match_modulepath ns mp with
-  | Some [] -> true
-  | _ -> false in
-  let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in
-  let constants_in_namespace =
-    Cmap_env.fold (fun c (body,_) acc ->
-      let kn = user_con c in
-      if matches (modpath kn) then
-        acc++fnl()++hov 2 (print_constant kn body)
-      else
-        acc
-    ) constants (str"")
-  in
-  Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace)
-
-let print_strategy r =
-  let open Conv_oracle in
-  let pr_level = function
-  | Expand -> str "expand"
-  | Level 0 -> str "transparent"
-  | Level n -> str "level" ++ spc() ++ int n
-  | Opaque -> str "opaque"
-  in
-  let pr_strategy (ref, lvl) = pr_global ref ++ str " : " ++ pr_level lvl in
-  let oracle = Environ.oracle (Global.env ()) in
-  match r with
-  | None ->
-    let fold key lvl (vacc, cacc) = match key with
-    | VarKey id -> ((VarRef id, lvl) :: vacc, cacc)
-    | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc)
-    | RelKey _ -> (vacc, cacc)
-    in
-    let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in
-    let var_msg =
-      if List.is_empty var_lvl then mt ()
-      else str "Variable strategies" ++ fnl () ++
-        hov 0 (prlist_with_sep fnl pr_strategy var_lvl) ++ fnl ()
-    in
-    let cst_msg =
-      if List.is_empty cst_lvl then mt ()
-      else str "Constant strategies" ++ fnl () ++
-        hov 0 (prlist_with_sep fnl pr_strategy cst_lvl)
-    in
-    Feedback.msg_notice (var_msg ++ cst_msg)
-  | Some r ->
-    let r = Smartlocate.smart_global r in
-    let key = match r with
-    | VarRef id -> VarKey id
-    | ConstRef cst -> ConstKey cst
-    | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable"
-    in
-    let lvl = get_strategy oracle key in
-    Feedback.msg_notice (pr_strategy (r, lvl))
-
-let dump_universes_gen g s =
-  let output = open_out s in
-  let output_constraint, close =
-    if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin
-      (* the lazy unit is to handle errors while printing the first line *)
-      let init = lazy (Printf.fprintf output "digraph universes {\n") in
-      begin fun kind left right ->
-        let () = Lazy.force init in
-        match kind with
-          | Univ.Lt ->
-            Printf.fprintf output "  \"%s\" -> \"%s\" [style=bold];\n" right left
-          | Univ.Le ->
-            Printf.fprintf output "  \"%s\" -> \"%s\" [style=solid];\n" right left
-          | Univ.Eq ->
-            Printf.fprintf output "  \"%s\" -> \"%s\" [style=dashed];\n" left right
-      end, begin fun () ->
-        if Lazy.is_val init then Printf.fprintf output "}\n";
-        close_out output
-      end
-    end else begin
-      begin fun kind left right ->
-        let kind = match kind with
-          | Univ.Lt -> "<"
-          | Univ.Le -> "<="
-          | Univ.Eq -> "="
-        in Printf.fprintf output "%s %s %s ;\n" left kind right
-      end, (fun () -> close_out output)
-    end
-  in
-  try
-    UGraph.dump_universes output_constraint g;
-    close ();
-    Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".")
-  with reraise ->
-    let reraise = CErrors.push reraise in
-    close ();
-    iraise reraise
-
-(*********************)
-(* "Locate" commands *)
-
-let locate_file f =
-  let file = Flags.silently Loadpath.locate_file f in
-  str file
-
-let msg_found_library = function
-  | Library.LibLoaded, fulldir, file ->
-      Feedback.msg_info (hov 0
-	(pr_dirpath fulldir ++ strbrk " has been loaded from file " ++
-	 str file))
-  | Library.LibInPath, fulldir, file ->
-      Feedback.msg_info (hov 0
-	(pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file))
-
-let err_unmapped_library loc ?from qid =
-  let dir = fst (repr_qualid qid) in
-  let prefix = match from with
-  | None -> str "."
-  | Some from ->
-    str " and prefix " ++ pr_dirpath from ++ str "."
-  in
-  user_err_loc
-    (loc,"locate_library",
-     strbrk "Cannot find a physical path bound to logical path matching suffix " ++
-       pr_dirpath dir ++ prefix)
-
-let err_notfound_library loc ?from qid =
-  let prefix = match from with
-  | None -> str "."
-  | Some from ->
-    str " with prefix " ++ pr_dirpath from ++ str "."
-  in
-  user_err_loc
-    (loc,"locate_library",
-     strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix)
-
-let print_located_library r =
-  let (loc,qid) = qualid_of_reference r in
-  try msg_found_library (Library.locate_qualified_library ~warn:false qid)
-  with
-    | Library.LibUnmappedDir -> err_unmapped_library loc qid
-    | Library.LibNotFound -> err_notfound_library loc qid
-
-let smart_global r =
-  let gr = Smartlocate.smart_global r in
-    Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr;
-    gr
-
-let dump_global r =
-  try
-    let gr = Smartlocate.smart_global r in
-    Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr
-  with e when CErrors.noncritical e -> ()
-(**********)
-(* Syntax *)
-
-let vernac_syntax_extension locality local =
-  let local = enforce_module_locality locality local in
-  Metasyntax.add_syntax_extension local
-
-let vernac_delimiters sc = function
-  | Some lr -> Metasyntax.add_delimiters sc lr
-  | None -> Metasyntax.remove_delimiters sc
-
-let vernac_bind_scope sc cll =
-  Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll)
-
-let vernac_open_close_scope locality local (b,s) =
-  let local = enforce_section_locality locality local in
-  Notation.open_close_scope (local,b,s)
-
-let vernac_arguments_scope locality r scl =
-  let local = make_section_locality locality in
-  Notation.declare_arguments_scope local (smart_global r) scl
-
-let vernac_infix locality local =
-  let local = enforce_module_locality locality local in
-  Metasyntax.add_infix local
-
-let vernac_notation locality local =
-  let local = enforce_module_locality locality local in
-  Metasyntax.add_notation local
-
-(***********)
-(* Gallina *)
-
-let start_proof_and_print k l hook =
-  let inference_hook =
-    if Flags.is_program_mode () then
-      let hook env sigma ev =
-        let tac = !Obligations.default_tactic in
-        let evi = Evd.find sigma ev in
-        let env = Evd.evar_filtered_env evi in
-        try
-          let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in
-          if Evarutil.has_undefined_evars sigma concl then raise Exit;
-          let c, _, ctx =
-            Pfedit.build_by_tactic env (Evd.evar_universe_context sigma)
-                                   concl (Tacticals.New.tclCOMPLETE tac)
-          in Evd.set_universe_context sigma ctx, c
-        with Logic_monad.TacticFailure e when Logic.catchable_exception e ->
-          error "The statement obligations could not be resolved \
-                 automatically, write a statement definition first."
-      in Some hook
-    else None
-  in
-  start_proof_com ?inference_hook k l hook
-
-let no_hook = Lemmas.mk_hook (fun _ _ -> ())
-
-let vernac_definition_hook p = function
-| Coercion -> Class.add_coercion_hook p
-| CanonicalStructure ->
-    Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure)
-| SubClass -> Class.add_subclass_hook p
-| _ -> no_hook
-
-let vernac_definition locality p (local,k) ((loc,id as lid),pl) def =
-  let local = enforce_locality_exp locality local in
-  let hook = vernac_definition_hook p k in
-  let () = match local with
-  | Discharge -> Dumpglob.dump_definition lid true "var"
-  | Local | Global -> Dumpglob.dump_definition lid false "def"
-  in
-  (match def with
-    | ProveBody (bl,t) ->   (* local binders, typ *)
-	  start_proof_and_print (local,p,DefinitionBody k)
-	    [Some (lid,pl), (bl,t,None)] hook
-    | DefineBody (bl,red_option,c,typ_opt) ->
- 	let red_option = match red_option with
-          | None -> None
-          | Some r ->
-	      let (evc,env)= get_current_context () in
- 		Some (snd (Hook.get f_interp_redexp env evc r)) in
-	do_definition id (local,p,k) pl bl red_option c typ_opt hook)
-
-let vernac_start_proof locality p kind l lettop =
-  let local = enforce_locality_exp locality None in
-  if Dumpglob.dump () then
-    List.iter (fun (id, _) ->
-      match id with
-	| Some (lid,_) -> Dumpglob.dump_definition lid false "prf"
-	| None -> ()) l;
-  if not(refining ()) then
-    if lettop then
-      errorlabstrm "Vernacentries.StartProof"
-	(str "Let declarations can only be used in proof editing mode.");
-  start_proof_and_print (local, p, Proof kind) l no_hook
-
-let qed_display_script = ref true
-
-let vernac_end_proof ?proof = function
-  | Admitted -> save_proof ?proof Admitted
-  | Proved (_,_) as e ->
-    if is_verbose () && !qed_display_script && !Flags.coqtop_ui then
-      Stm.show_script ?proof ();
-    save_proof ?proof e
-
-  (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
-     the theories [??] *)
-
-let vernac_exact_proof c =
-  (* spiwack: for simplicity I do not enforce that "Proof proof_term" is
-     called only at the begining of a proof. *)
-  let status = by (Tactics.exact_proof c) in
-  save_proof (Vernacexpr.(Proved(Opaque None,None)));
-  if not status then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_assumption locality poly (local, kind) l nl =
-  let local = enforce_locality_exp locality local in
-  let global = local == Global in
-  let kind = local, poly, kind in
-  List.iter (fun (is_coe,(idl,c)) ->
-    if Dumpglob.dump () then
-      List.iter (fun (lid, _) ->
-	if global then Dumpglob.dump_definition lid false "ax"
-	else Dumpglob.dump_definition lid true "var") idl) l;
-  let status = do_assumptions kind nl l in
-  if not status then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_record k poly finite struc binders sort nameopt cfs =
-  let const = match nameopt with
-    | None -> add_prefix "Build_" (snd (fst (snd struc)))
-    | Some (_,id as lid) ->
-	Dumpglob.dump_definition lid false "constr"; id in
-    if Dumpglob.dump () then (
-      Dumpglob.dump_definition (fst (snd struc)) false "rec";
-      List.iter (fun (((_, x), _), _) ->
-	match x with
-	| Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj"
-	| _ -> ()) cfs);
-    ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort))
-
-(** When [poly] is true the type is declared polymorphic. When [lo] is true,
-    then the type is declared private (as per the [Private] keyword). [finite]
-    indicates whether the type is inductive, co-inductive or
-    neither. *)
-let vernac_inductive poly lo finite indl =
-  if Dumpglob.dump () then
-    List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) ->
-      match cstrs with
-	| Constructors cstrs ->
-	    Dumpglob.dump_definition lid false "ind";
-	    List.iter (fun (_, (lid, _)) ->
-			 Dumpglob.dump_definition lid false "constr") cstrs
-	| _ -> () (* dumping is done by vernac_record (called below) *) )
-      indl;
-  match indl with
-  | [ ( _ , _ , _ ,Record, Constructors _ ),_ ] ->
-      CErrors.error "The Record keyword cannot be used to define a variant type. Use Variant instead."
-  | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] ->
-      CErrors.error "The Variant keyword cannot be used to define a record type. Use Record instead."
-  | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] ->
-      vernac_record (match b with Class _ -> Class false | _ -> b)
-       poly finite id bl c oc fs
-  | [ ( id , bl , c , Class _, Constructors [l]), [] ] ->
-      let f =
-	let (coe, ((loc, id), ce)) = l in
-	let coe' = if coe then Some true else None in
-  	  (((coe', AssumExpr ((loc, Name id), ce)), None), [])
-      in vernac_record (Class true) poly finite id bl c None [f]
-  | [ ( _ , _, _, Class _, Constructors _), [] ] ->
-      CErrors.error "Inductive classes not supported"
-  | [ ( id , bl , c , Class _, _), _ :: _ ] ->
-      CErrors.error "where clause not supported for classes"
-  | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
-      CErrors.error "where clause not supported for (co)inductive records"
-  | _ -> let unpack = function
-      | ( (false, id) , bl , c , _ , Constructors l ) , ntn  -> ( id , bl , c , l ) , ntn
-      | ( (true,_),_,_,_,Constructors _),_ ->
-          CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead."
-      | _ -> CErrors.error "Cannot handle mutually (co)inductive records."
-    in
-    let indl = List.map unpack indl in
-    do_mutual_inductive indl poly lo finite
-
-let vernac_fixpoint locality poly local l =
-  let local = enforce_locality_exp locality local in
-  if Dumpglob.dump () then
-    List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_fixpoint local poly l
-
-let vernac_cofixpoint locality poly local l =
-  let local = enforce_locality_exp locality local in
-  if Dumpglob.dump () then
-    List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_cofixpoint local poly l
-
-let vernac_scheme l =
-  if Dumpglob.dump () then
-    List.iter (fun (lid, s) ->
-	       Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid;
-	       match s with
-	       | InductionScheme (_, r, _)
-	       | CaseScheme (_, r, _) 
-	       | EqualityScheme r -> dump_global r) l;
-  Indschemes.do_scheme l
-
-let vernac_combined_scheme lid l =
-  if Dumpglob.dump () then
-    (Dumpglob.dump_definition lid false "def";
-     List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l);
- Indschemes.do_combined_scheme lid l
-
-let vernac_universe loc poly l =
-  if poly && not (Lib.sections_are_opened ()) then
-    user_err_loc (loc, "vernac_universe",
-		  str"Polymorphic universes can only be declared inside sections, " ++
-		  str "use Monomorphic Universe instead");
-  do_universe poly l
-
-let vernac_constraint loc poly l =
-  if poly && not (Lib.sections_are_opened ()) then
-    user_err_loc (loc, "vernac_constraint",
-		  str"Polymorphic universe constraints can only be declared"
-		  ++ str " inside sections, use Monomorphic Constraint instead");
-  do_constraint poly l
-
-(**********************)
-(* Modules            *)
-
-let vernac_import export refl =
-  Library.import_module export (List.map qualid_of_reference refl);
-  Lib.add_frozen_state ()
-
-let vernac_declare_module export (loc, id) binders_ast mty_ast =
-  (* We check the state of the system (in section, in module type)
-     and what module information is supplied *)
-  if Lib.sections_are_opened () then
-    error "Modules and Module Types are not allowed inside sections.";
-  let binders_ast = List.map
-   (fun (export,idl,ty) ->
-     if not (Option.is_empty export) then
-      error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument."
-     else (idl,ty)) binders_ast in
-  let mp =
-    Declaremods.declare_module Modintern.interp_module_ast
-      id binders_ast (Enforce mty_ast) []
-  in
-  Dumpglob.dump_moddef loc mp "mod";
-  if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared");
-  Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
-
-let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
-  (* We check the state of the system (in section, in module type)
-     and what module information is supplied *)
-  if Lib.sections_are_opened () then
-    error "Modules and Module Types are not allowed inside sections.";
-  match mexpr_ast_l with
-    | [] ->
-       check_no_pending_proofs ();
-       let binders_ast,argsexport =
-        List.fold_right
-         (fun (export,idl,ty) (args,argsexport) ->
-           (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
-             ([],[]) in
-       let mp =
-         Declaremods.start_module Modintern.interp_module_ast
-           export id binders_ast mty_ast_o
-       in
-       Dumpglob.dump_moddef loc mp "mod";
-       if_verbose Feedback.msg_info
-         (str "Interactive Module " ++ pr_id id ++ str " started");
-       List.iter
-         (fun (export,id) ->
-           Option.iter
-             (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
-         ) argsexport
-    | _::_ ->
-       let binders_ast = List.map
-        (fun (export,idl,ty) ->
-          if not (Option.is_empty export) then
-           error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument."
-          else (idl,ty)) binders_ast in
-       let mp =
-         Declaremods.declare_module Modintern.interp_module_ast
-	   id binders_ast mty_ast_o mexpr_ast_l
-       in
-       Dumpglob.dump_moddef loc mp "mod";
-       if_verbose Feedback.msg_info
-	 (str "Module " ++ pr_id id ++ str " is defined");
-       Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)])
-         export
-
-let vernac_end_module export (loc,id as lid) =
-  let mp = Declaremods.end_module () in
-  Dumpglob.dump_modref loc mp "mod";
-  if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined");
-  Option.iter (fun export -> vernac_import export [Ident lid]) export
-
-let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
-  if Lib.sections_are_opened () then
-    error "Modules and Module Types are not allowed inside sections.";
-
-  match mty_ast_l with
-    | [] ->
-       check_no_pending_proofs ();
-       let binders_ast,argsexport =
-	 List.fold_right
-         (fun (export,idl,ty) (args,argsexport) ->
-           (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
-             ([],[]) in
-
-       let mp =
-         Declaremods.start_modtype Modintern.interp_module_ast
-           id binders_ast mty_sign
-       in
-       Dumpglob.dump_moddef loc mp "modtype";
-       if_verbose Feedback.msg_info
-	 (str "Interactive Module Type " ++ pr_id id ++ str " started");
-       List.iter
-         (fun (export,id) ->
-           Option.iter
-             (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
-         ) argsexport
-
-    | _ :: _ ->
-	let binders_ast = List.map
-          (fun (export,idl,ty) ->
-            if not (Option.is_empty export) then
-              error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument."
-            else (idl,ty)) binders_ast in
-	let mp =
-          Declaremods.declare_modtype Modintern.interp_module_ast
-	    id binders_ast mty_sign mty_ast_l
-        in
-        Dumpglob.dump_moddef loc mp "modtype";
-	if_verbose Feedback.msg_info
-	  (str "Module Type " ++ pr_id id ++ str " is defined")
-
-let vernac_end_modtype (loc,id) =
-  let mp = Declaremods.end_modtype () in
-  Dumpglob.dump_modref loc mp "modtype";
-  if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
-
-let vernac_include l =
-  Declaremods.declare_include Modintern.interp_module_ast l
-
-(**********************)
-(* Gallina extensions *)
-
-(* Sections *)
-
-let vernac_begin_section (_, id as lid) =
-  check_no_pending_proofs ();
-  Dumpglob.dump_definition lid true "sec";
-  Lib.open_section id
-
-let vernac_end_section (loc,_) =
-  Dumpglob.dump_reference loc
-    (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec";
-  Lib.close_section ()
-
-let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set
-
-(* Dispatcher of the "End" command *)
-
-let vernac_end_segment (_,id as lid) =
-  check_no_pending_proofs ();
-  match Lib.find_opening_node id with
-  | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid
-  | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid
-  | Lib.OpenedSection _ -> vernac_end_section lid
-  | _ -> assert false
-
-(* Libraries *)
-
-let vernac_require from import qidl =
-  let qidl = List.map qualid_of_reference qidl in
-  let root = match from with
-  | None -> None
-  | Some from ->
-    let (_, qid) = Libnames.qualid_of_reference from in
-    let (hd, tl) = Libnames.repr_qualid qid in
-    Some (Libnames.add_dirpath_suffix hd tl)
-  in
-  let locate (loc, qid) =
-    try
-      let warn = Flags.is_verbose () in
-      let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in
-      (dir, f)
-    with
-      | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid
-      | Library.LibNotFound -> err_notfound_library loc ?from:root qid
-  in
-  let modrefl = List.map locate qidl in
-  if Dumpglob.dump () then
-    List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl);
-  Library.require_library_from_dirpath modrefl import
-
-(* Coercions and canonical structures *)
-
-let vernac_canonical r =
-  Recordops.declare_canonical_structure (smart_global r)
-
-let vernac_coercion locality poly local ref qids qidt =
-  let local = enforce_locality locality local in
-  let target = cl_of_qualid qidt in
-  let source = cl_of_qualid qids in
-  let ref' = smart_global ref in
-  Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target;
-  if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
-
-let vernac_identity_coercion locality poly local id qids qidt =
-  let local = enforce_locality locality local in
-  let target = cl_of_qualid qidt in
-  let source = cl_of_qualid qids in
-  Class.try_add_new_identity_coercion id ~local poly ~source ~target
-
-(* Type classes *)
-
-let vernac_instance abst locality poly sup inst props pri =
-  let global = not (make_section_locality locality) in
-  Dumpglob.dump_constraint inst false "inst";
-  ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri)
-
-let vernac_context poly l =
-  if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_declare_instances locality insts =
-  let glob = not (make_section_locality locality) in
-  List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts
-
-let vernac_declare_class id =
-  Record.declare_existing_class (Nametab.global id)
-
-(***********)
-(* Solving *)
-
-let command_focus = Proof.new_focus_kind ()
-let focus_command_cond = Proof.no_cond command_focus
-
-  (* A command which should be a tactic. It has been
-     added by Christine to patch an error in the design of the proof
-     machine, and enables to instantiate existential variables when
-     there are no more goals to solve. It cannot be a tactic since
-     all tactics fail if there are no further goals to prove. *)
-
-let vernac_solve_existential = instantiate_nth_evar_com
-
-let vernac_set_end_tac tac =
-  if not (refining ()) then
-    error "Unknown command of the non proof-editing mode.";
-  match tac with
-  | Tacexpr.TacId [] -> ()
-  | _ -> set_end_tac tac
-    (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
-
-let vernac_set_used_variables e =
-  let open Context.Named.Declaration in
-  let env = Global.env () in
-  let tys =
-    List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in
-  let l = Proof_using.process_expr env e tys in
-  let vars = Environ.named_context env in
-  List.iter (fun id -> 
-    if not (List.exists (Id.equal id % get_id) vars) then
-      errorlabstrm "vernac_set_used_variables"
-        (str "Unknown variable: " ++ pr_id id))
-    l;
-  let _, to_clear = set_used_variables l in
-  let to_clear = List.map snd to_clear in
-  Proof_global.with_current_proof begin fun _ p ->
-    if List.is_empty to_clear then (p, ())
-    else
-      let tac = Tactics.clear to_clear in
-      fst (solve SelectAll None tac p), ()
-  end
-
-(*****************************)
-(* Auxiliary file management *)
-
-let expand filename =
-  Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename
-
-let vernac_add_loadpath implicit pdir ldiropt =
-  let pdir = expand pdir in
-  let alias = Option.default Nameops.default_root_prefix ldiropt in
-  Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit
-
-let vernac_remove_loadpath path =
-  Loadpath.remove_load_path (expand path)
-
-  (* Coq syntax for ML or system commands *)
-
-let vernac_add_ml_path isrec path =
-  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path)
-
-let vernac_declare_ml_module locality l =
-  let local = make_locality locality in
-  Mltop.declare_ml_modules local (List.map expand l)
-
-let vernac_chdir = function
-  | None -> Feedback.msg_notice (str (Sys.getcwd()))
-  | Some path ->
-      begin
-	try Sys.chdir (expand path)
-	with Sys_error err ->
-	  (* Cd is typically used to control the output directory of
-	  extraction. A failed Cd could lead to overwriting .ml files
-	  so we make it an error. *)
-	  CErrors.error ("Cd failed: " ^ err)
-      end;
-      if_verbose Feedback.msg_info (str (Sys.getcwd()))
-
-
-(********************)
-(* State management *)
-
-let vernac_write_state file =
-  Pfedit.delete_all_proofs ();
-  let file = CUnix.make_suffix file ".coq" in
-  States.extern_state file
-
-let vernac_restore_state file =
-  Pfedit.delete_all_proofs ();
-  let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in
-  States.intern_state file
-
-(************)
-(* Commands *)
-
-let vernac_create_hintdb locality id b =
-  let local = make_module_locality locality in
-  Hints.create_hint_db local id full_transparent_state b
-
-let vernac_remove_hints locality dbs ids =
-  let local = make_module_locality locality in
-  Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids)
-
-let vernac_hints locality poly local lb h =
-  let local = enforce_module_locality locality local in
-  Hints.add_hints local lb (Hints.interp_hints poly h)
-
-let vernac_syntactic_definition locality lid x local y =
-  Dumpglob.dump_definition lid false "syndef";
-  let local = enforce_module_locality locality local in
-  Metasyntax.add_syntactic_definition (snd lid) x local y
-
-let vernac_declare_implicits locality r l =
-  let local = make_section_locality locality in
-  match l with
-  | [] ->
-      Impargs.declare_implicits local (smart_global r)
-  | _::_ as imps ->
-      Impargs.declare_manual_implicits local (smart_global r) ~enriching:false
-	(List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps)
-
-let warn_arguments_assert =
-  CWarnings.create ~name:"arguments-assert" ~category:"vernacular"
-         (fun sr ->
-          strbrk "This command is just asserting the names of arguments of " ++
-            pr_global sr ++ strbrk". If this is what you want add " ++
-            strbrk "': assert' to silence the warning. If you want " ++
-            strbrk "to clear implicit arguments add ': clear implicits'. " ++
-            strbrk "If you want to clear notation scopes add ': clear scopes'")
-
-(* [nargs_for_red] is the number of arguments required to trigger reduction,
-   [args] is the main list of arguments statuses,
-   [more_implicits] is a list of extra lists of implicit statuses  *)
-let vernac_arguments locality reference args more_implicits nargs_for_red flags =
-  let assert_flag = List.mem `Assert flags in
-  let rename_flag = List.mem `Rename flags in
-  let clear_scopes_flag = List.mem `ClearScopes flags in
-  let extra_scopes_flag = List.mem `ExtraScopes flags in
-  let clear_implicits_flag = List.mem `ClearImplicits flags in
-  let default_implicits_flag = List.mem `DefaultImplicits flags in
-  let never_unfold_flag = List.mem `ReductionNeverUnfold flags in
-
-  let err_incompat x y =
-    error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in
-
-  if assert_flag && rename_flag then
-    err_incompat "assert" "rename";
-  if Option.has_some nargs_for_red && never_unfold_flag then
-    err_incompat "simpl never" "/";
-  if never_unfold_flag && List.mem `ReductionDontExposeCase flags then
-    err_incompat "simpl never" "simpl nomatch";
-  if clear_scopes_flag && extra_scopes_flag then
-    err_incompat "clear scopes" "extra scopes";
-  if clear_implicits_flag && default_implicits_flag then
-    err_incompat "clear implicits" "default implicits";
-
-  let sr = smart_global reference in
-  let inf_names =
-    let ty = Global.type_of_global_unsafe sr in
-    Impargs.compute_implicits_names (Global.env ()) ty
-  in
-  let prev_names =
-    try Arguments_renaming.arguments_names sr with Not_found -> inf_names
-  in
-  let num_args = List.length inf_names in
-  assert (Int.equal num_args (List.length prev_names));
-
-  let names_of args = List.map (fun a -> a.name) args in
-
-  (* Checks *)
-
-  let err_extra_args names =
-    errorlabstrm "vernac_declare_arguments"
-                 (strbrk "Extra arguments: " ++
-                    prlist_with_sep pr_comma pr_name names ++ str ".")
-  in
-  let err_missing_args names =
-    errorlabstrm "vernac_declare_arguments"
-                 (strbrk "The following arguments are not declared: " ++
-                    prlist_with_sep pr_comma pr_name names ++ str ".")
-  in
-
-  let rec check_extra_args extra_args =
-    match extra_args with
-    | [] -> ()
-    | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args)
-    | { name = Anonymous; notation_scope = Some _ } :: args ->
-       check_extra_args args
-    | _ ->
-       error "Extra notation scopes can be set on anonymous and explicit arguments only."
-  in
-
-  let args, scopes =
-    let scopes = List.map (fun { notation_scope = s } -> s) args in
-    if List.length args > num_args then
-      let args, extra_args = List.chop num_args args in
-      if extra_scopes_flag then
-        (check_extra_args extra_args; (args, scopes))
-      else err_extra_args (names_of extra_args)
-    else args, scopes
-  in
-
-  if Option.cata (fun n -> n > num_args) false nargs_for_red then
-    error "The \"/\" modifier should be put before any extra scope.";
-
-  let scopes_specified = List.exists Option.has_some scopes in
-  
-  if scopes_specified && clear_scopes_flag then
-    error "The \"clear scopes\" flag is incompatible with scope annotations.";
-
-  let names = List.map (fun { name } -> name) args in
-  let names = names :: List.map (List.map fst) more_implicits in
-
-  let rename_flag_required = ref false in
-  let example_renaming = ref None in
-  let save_example_renaming renaming =
-    rename_flag_required := !rename_flag_required
-                            || not (Name.equal (fst renaming) Anonymous);
-    if Option.is_empty !example_renaming then
-      example_renaming := Some renaming
-  in
-
-  let rec names_union names1 names2 =
-    match names1, names2 with
-    | [], [] -> []
-    | _ :: _, [] -> names1
-    | [], _ :: _ -> names2
-    | (Name _ as name) :: names1, Anonymous :: names2
-    | Anonymous :: names1, (Name _ as name) :: names2 ->
-       name :: names_union names1 names2
-    | name1 :: names1, name2 :: names2 ->
-       if Name.equal name1 name2 then
-         name1 :: names_union names1 names2
-       else error "Argument lists should agree on the names they provide."
-  in
-
-  let names = List.fold_left names_union [] names in
-
-  let rec rename prev_names names =
-    match prev_names, names with
-    | [], [] -> []
-    | [], _ :: _ -> err_extra_args names
-    | _ :: _, [] when assert_flag ->
-       (* Error messages are expressed in terms of original names, not
-            renamed ones. *)
-       err_missing_args (List.lastn (List.length prev_names) inf_names)
-    | _ :: _, [] -> prev_names
-    | prev :: prev_names, Anonymous :: names ->
-       prev :: rename prev_names names
-    | prev :: prev_names, (Name id as name) :: names ->
-       if not (Name.equal prev name) then save_example_renaming (prev,name);
-       name :: rename prev_names names
-  in
-  
-  let names = rename prev_names names in
-  let renaming_specified = Option.has_some !example_renaming in
-
-  if !rename_flag_required && not rename_flag then
-    errorlabstrm "vernac_declare_arguments"
-      (strbrk "To rename arguments the \"rename\" flag must be specified."
-    ++ spc () ++
-       match !example_renaming with
-       | None -> mt ()
-       | Some (o,n) ->
-          str "Argument " ++ pr_name o ++
-            str " renamed to " ++ pr_name n ++ str ".");
-
-  let duplicate_names =
-    List.duplicates Name.equal (List.filter ((!=) Anonymous) names)
-  in
-  if not (List.is_empty duplicate_names) then begin
-    let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in
-    errorlabstrm "_" (strbrk "Some argument names are duplicated: " ++ duplicates)
-  end;
-
-  (* Parts of this code are overly complicated because the implicit arguments
-     API is completely crazy: positions (ExplByPos) are elaborated to
-     names. This is broken by design, since not all arguments have names. So
-     even though we eventually want to map only positions to implicit statuses,
-     we have to check whether the corresponding arguments have names, not to
-     trigger an error in the impargs code. Even better, the names we have to
-     check are not the current ones (after previous renamings), but the original
-     ones (inferred from the type). *)
-
-  let implicits =
-    List.map (fun { name; implicit_status = i } -> (name,i)) args
-  in
-  let implicits = implicits :: more_implicits in
-
-  let open Vernacexpr in
-  let rec build_implicits inf_names implicits =
-    match inf_names, implicits with
-    | _, [] -> []
-    | _ :: inf_names, (_, NotImplicit) :: implicits ->
-       build_implicits inf_names implicits
-
-    (* With the current impargs API, it is impossible to make an originally
-       anonymous argument implicit *)
-    | Anonymous :: _, (name, _) :: _ ->
-       errorlabstrm "vernac_declare_arguments"
-                    (strbrk"Argument "++ pr_name name ++ 
-                       strbrk " cannot be declared implicit.")
-
-    | Name id :: inf_names, (name, impl) :: implicits ->
-       let max = impl = MaximallyImplicit in
-       (ExplByName id,max,false) :: build_implicits inf_names implicits
-    
-    | _ -> assert false (* already checked in [names_union] *)
-  in
-  
-  let implicits = List.map (build_implicits inf_names) implicits in
-  let implicits_specified = match implicits with [[]] -> false | _ -> true in
-
-  if implicits_specified && clear_implicits_flag then
-    error "The \"clear implicits\" flag is incompatible with implicit annotations";
-
-  if implicits_specified && default_implicits_flag then
-    error "The \"default implicits\" flag is incompatible with implicit annotations";
-
-  let rargs =
-    Util.List.map_filter (function (n, true) -> Some n | _ -> None)
-      (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args)
-  in
-
-  let rec narrow = function
-    | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl
-    | [] -> [] | _ :: tl -> narrow tl
-  in
-  let red_flags = narrow flags in
-  let red_modifiers_specified =
-    not (List.is_empty rargs) || Option.has_some nargs_for_red
-    || not (List.is_empty red_flags)
-  in
-
-  if not (List.is_empty rargs) && never_unfold_flag then
-    err_incompat "simpl never" "!";
-
-
-  (* Actions *)
-
-  if renaming_specified then begin
-    let local = make_section_locality locality in
-    Arguments_renaming.rename_arguments local sr names
-  end;
-
-  if scopes_specified || clear_scopes_flag then begin
-      let scopes = List.map (Option.map (fun (o,k) -> 
-        try ignore (Notation.find_scope k); k
-        with UserError _ ->
-          Notation.find_delimiters_scope o k)) scopes
-      in
-      vernac_arguments_scope locality reference scopes
-    end;
-
-  if implicits_specified || clear_implicits_flag then
-    vernac_declare_implicits locality reference implicits;
-
-  if default_implicits_flag then
-    vernac_declare_implicits locality reference [];
-
-  if red_modifiers_specified then begin
-    match sr with
-    | ConstRef _ as c ->
-       Reductionops.ReductionBehaviour.set
-         (make_section_locality locality) c
-         (rargs, Option.default ~-1 nargs_for_red, red_flags)
-    | _ -> errorlabstrm ""
-             (strbrk "Modifiers of the behavior of the simpl tactic "++
-              strbrk "are relevant for constants only.")
-  end;
-
- if not (renaming_specified ||
-         implicits_specified ||
-         scopes_specified ||
-         red_modifiers_specified) && (List.is_empty flags) then
-    warn_arguments_assert sr
-
-let default_env () = {
-  Notation_term.ninterp_var_type = Id.Map.empty;
-  ninterp_rec_vars = Id.Map.empty;
-}
-
-let vernac_reserve bl =
-  let sb_decl = (fun (idl,c) ->
-    let env = Global.env() in
-    let sigma = Evd.from_env env in
-    let t,ctx = Constrintern.interp_type env sigma c in
-    let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in
-    let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in
-    Reserve.declare_reserved_type idl t)
-  in List.iter sb_decl bl
-
-let vernac_generalizable locality =
-  let local = make_non_locality locality in
-  Implicit_quantifiers.declare_generalizable local
-
-let _ =
-  declare_bool_option
-    { optsync  = false;
-      optdepr  = false;
-      optname  = "silent";
-      optkey   = ["Silent"];
-      optread  = is_silent;
-      optwrite = make_silent }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "implicit arguments";
-      optkey   = ["Implicit";"Arguments"];
-      optread  = Impargs.is_implicit_args;
-      optwrite = Impargs.make_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "strict implicit arguments";
-      optkey   = ["Strict";"Implicit"];
-      optread  = Impargs.is_strict_implicit_args;
-      optwrite = Impargs.make_strict_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "strong strict implicit arguments";
-      optkey   = ["Strongly";"Strict";"Implicit"];
-      optread  = Impargs.is_strongly_strict_implicit_args;
-      optwrite = Impargs.make_strongly_strict_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "contextual implicit arguments";
-      optkey   = ["Contextual";"Implicit"];
-      optread  = Impargs.is_contextual_implicit_args;
-      optwrite = Impargs.make_contextual_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "implicit status of reversible patterns";
-      optkey   = ["Reversible";"Pattern";"Implicit"];
-      optread  = Impargs.is_reversible_pattern_implicit_args;
-      optwrite = Impargs.make_reversible_pattern_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "maximal insertion of implicit";
-      optkey   = ["Maximal";"Implicit";"Insertion"];
-      optread  = Impargs.is_maximal_implicit_args;
-      optwrite = Impargs.make_maximal_implicit_args }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "automatic introduction of variables";
-      optkey   = ["Automatic";"Introduction"];
-      optread  = Flags.is_auto_intros;
-      optwrite = make_auto_intros }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "coercion printing";
-      optkey   = ["Printing";"Coercions"];
-      optread  = (fun () -> !Constrextern.print_coercions);
-      optwrite = (fun b ->  Constrextern.print_coercions := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "printing of existential variable instances";
-      optkey   = ["Printing";"Existential";"Instances"];
-      optread  = (fun () -> !Detyping.print_evar_arguments);
-      optwrite = (:=) Detyping.print_evar_arguments }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "implicit arguments printing";
-      optkey   = ["Printing";"Implicit"];
-      optread  = (fun () -> !Constrextern.print_implicits);
-      optwrite = (fun b ->  Constrextern.print_implicits := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "implicit arguments defensive printing";
-      optkey   = ["Printing";"Implicit";"Defensive"];
-      optread  = (fun () -> !Constrextern.print_implicits_defensive);
-      optwrite = (fun b ->  Constrextern.print_implicits_defensive := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "projection printing using dot notation";
-      optkey   = ["Printing";"Projections"];
-      optread  = (fun () -> !Constrextern.print_projections);
-      optwrite = (fun b ->  Constrextern.print_projections := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "notations printing";
-      optkey   = ["Printing";"Notations"];
-      optread  = (fun () -> not !Constrextern.print_no_symbol);
-      optwrite = (fun b ->  Constrextern.print_no_symbol := not b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "raw printing";
-      optkey   = ["Printing";"All"];
-      optread  = (fun () -> !Flags.raw_print);
-      optwrite = (fun b -> Flags.raw_print := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "record printing";
-      optkey   = ["Printing";"Records"];
-      optread  = (fun () -> !Flags.record_print);
-      optwrite = (fun b -> Flags.record_print := b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "use of the program extension";
-      optkey   = ["Program";"Mode"];
-      optread  = (fun () -> !Flags.program_mode);
-      optwrite = (fun b -> Flags.program_mode:=b) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "universe polymorphism";
-      optkey   = ["Universe"; "Polymorphism"];
-      optread  = Flags.is_universe_polymorphism;
-      optwrite = Flags.make_universe_polymorphism }
-
-let _ =
-  declare_int_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "the level of inlining during functor application";
-      optkey   = ["Inline";"Level"];
-      optread  = (fun () -> Some (Flags.get_inline_level ()));
-      optwrite = (fun o ->
-	           let lev = Option.default Flags.default_inline_level o in
-	           Flags.set_inline_level lev) }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "kernel term sharing";
-      optkey   = ["Kernel"; "Term"; "Sharing"];
-      optread  = (fun () -> !CClosure.share);
-      optwrite = (fun b -> CClosure.share := b) }
-
-(* No more undo limit in the new proof engine.
-   The command still exists for compatibility (e.g. with ProofGeneral) *)
-
-let _ =
-  declare_int_option
-    { optsync  = false;
-      optdepr  = true;
-      optname  = "the undo limit (OBSOLETE)";
-      optkey   = ["Undo"];
-      optread  = (fun _ -> None);
-      optwrite = (fun _ -> ()) }
-
-let _ =
-  declare_int_option
-    { optsync  = false;
-      optdepr  = false;
-      optname  = "the hypotheses limit";
-      optkey   = ["Hyps";"Limit"];
-      optread  = Flags.print_hyps_limit;
-      optwrite = Flags.set_print_hyps_limit }
-
-let _ =
-  declare_int_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "the printing depth";
-      optkey   = ["Printing";"Depth"];
-      optread  = Pp_control.get_depth_boxes;
-      optwrite = Pp_control.set_depth_boxes }
-
-let _ =
-  declare_int_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "the printing width";
-      optkey   = ["Printing";"Width"];
-      optread  = Pp_control.get_margin;
-      optwrite = Pp_control.set_margin }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "printing of universes";
-      optkey   = ["Printing";"Universes"];
-      optread  = (fun () -> !Constrextern.print_universes);
-      optwrite = (fun b -> Constrextern.print_universes:=b) }
-     
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "dumping bytecode after compilation";
-      optkey   = ["Dump";"Bytecode"];
-      optread  = Flags.get_dump_bytecode;
-      optwrite = Flags.set_dump_bytecode }
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "explicitly parsing implicit arguments";
-      optkey   = ["Parsing";"Explicit"];
-      optread  = (fun () -> !Constrintern.parsing_explicit);
-      optwrite = (fun b ->  Constrintern.parsing_explicit := b) }
-
-let _ =
-  declare_string_option ~preprocess:CWarnings.normalize_flags_string
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "warnings display";
-      optkey   = ["Warnings"];
-      optread  = CWarnings.get_flags;
-      optwrite = CWarnings.set_flags }
-
-let vernac_set_strategy locality l =
-  let local = make_locality locality in
-  let glob_ref r =
-    match smart_global r with
-      | ConstRef sp -> EvalConstRef sp
-      | VarRef id -> EvalVarRef id
-      | _ -> error
-          "cannot set an inductive type or a constructor as transparent" in
-  let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in
-  Redexpr.set_strategy local l
-
-let vernac_set_opacity locality (v,l) =
-  let local = make_non_locality locality in
-  let glob_ref r =
-    match smart_global r with
-      | ConstRef sp -> EvalConstRef sp
-      | VarRef id -> EvalVarRef id
-      | _ -> error
-          "cannot set an inductive type or a constructor as transparent" in
-  let l = List.map glob_ref l in
-  Redexpr.set_strategy local [v,l]
-
-let vernac_set_option locality key = function
-  | StringValue s -> set_string_option_value_gen locality key s
-  | StringOptValue (Some s) -> set_string_option_value_gen locality key s
-  | StringOptValue None -> unset_option_value_gen locality key
-  | IntValue n -> set_int_option_value_gen locality key n
-  | BoolValue b -> set_bool_option_value_gen locality key b
-
-let vernac_set_append_option locality key s =
-  set_string_option_append_value_gen locality key s
-
-let vernac_unset_option locality key =
-  unset_option_value_gen locality key
-
-let vernac_add_option key lv =
-  let f = function
-    | StringRefValue s -> (get_string_table key)#add s
-    | QualidRefValue locqid -> (get_ref_table key)#add locqid
-  in
-  try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_remove_option key lv =
-  let f = function
-  | StringRefValue s -> (get_string_table key)#remove s
-  | QualidRefValue locqid -> (get_ref_table key)#remove locqid
-  in
-  try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_mem_option key lv =
-  let f = function
-  | StringRefValue s -> (get_string_table key)#mem s
-  | QualidRefValue locqid -> (get_ref_table key)#mem locqid
-  in
-  try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_print_option key =
-  try (get_ref_table key)#print
-  with Not_found ->
-  try (get_string_table key)#print
-  with Not_found ->
-  try print_option_value key
-  with Not_found -> error_undeclared_key key
-
-let get_current_context_of_args = function
-  | Some n -> get_goal_context n
-  | None -> get_current_context ()
-
-let vernac_check_may_eval redexp glopt rc =
-  let (sigma, env) = get_current_context_of_args glopt in
-  let sigma', c = interp_open_constr env sigma rc in
-  let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in
-  Evarconv.check_problems_are_solved env sigma';
-  let sigma',nf = Evarutil.nf_evars_and_universes sigma' in
-  let pl, uctx = Evd.universe_context sigma' in
-  let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in
-  let c = nf c in
-  let j =
-    if Evarutil.has_undefined_evars sigma' c then
-      Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c)
-    else
-      (* OK to call kernel which does not support evars *)
-      Arguments_renaming.rename_typing env c in
-  match redexp with
-    | None ->
-        let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in
-        let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in
-	Feedback.msg_notice (print_judgment env sigma' j ++
-                    pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++
-                    Printer.pr_universe_ctx sigma uctx)
-    | Some r ->
-        let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in
-	let redfun env evm c =
-          let (redfun, _) = reduction_of_red_expr env r_interp in
-          let evm = Sigma.Unsafe.of_evar_map evm in
-          let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in
-          c
-        in
-	Feedback.msg_notice (print_eval redfun env sigma' rc j)
-
-let vernac_declare_reduction locality s r =
-  let local = make_locality locality in
-  declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r))
-
-  (* The same but avoiding the current goal context if any *)
-let vernac_global_check c =
-  let env = Global.env() in
-  let sigma = Evd.from_env env in
-  let c,ctx = interp_constr env sigma c in
-  let senv = Global.safe_env() in
-  let cstrs = snd (UState.context_set ctx) in
-  let senv = Safe_typing.add_constraints cstrs senv in
-  let j = Safe_typing.typing senv c in
-  let env = Safe_typing.env_of_safe_env senv in
-    Feedback.msg_notice (print_safe_judgment env sigma j)
-
-
-let get_nth_goal n =
-  let pf = get_pftreestate() in
-  let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
-  let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in
-  gl
-  
-exception NoHyp
-(* Printing "About" information of a hypothesis of the current goal.
-   We only print the type and a small statement to this comes from the
-   goal. Precondition: there must be at least one current goal. *)
-let print_about_hyp_globs ref_or_by_not glnumopt =
-  let open Context.Named.Declaration in
-  try
-    let gl,id =
-      match glnumopt,ref_or_by_not with
-      | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *)
-	 (try get_nth_goal 1,id with _ -> raise NoHyp)
-      | Some n,AN (Ident (_loc,id)) ->  (* goal number given, catch if wong *)
-	 (try get_nth_goal n,id
-	  with
-	    Failure _ -> errorlabstrm "print_about_hyp_globs"
-                           (str "No such goal: " ++ int n ++ str "."))
-      | _ , _ -> raise NoHyp in
-    let hyps = pf_hyps gl in
-    let decl = Context.Named.lookup id hyps in
-    let natureofid = match decl with
-                     | LocalAssum _ -> "Hypothesis"
-                     | LocalDef (_,bdy,_) ->"Constant (let in)" in
-    v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl()
-	 ++ str natureofid ++ str " of the goal context.")
-  with (* fallback to globals *)
-    | NoHyp | Not_found -> print_about ref_or_by_not
-
-	       
-let vernac_print = let open Feedback in function
-  | PrintTables -> msg_notice (print_tables ())
-  | PrintFullContext-> msg_notice (print_full_context_typ ())
-  | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid)
-  | PrintInspect n -> msg_notice (inspect n)
-  | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent)
-  | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir)
-  | PrintModules -> msg_notice (print_modules ())
-  | PrintModule qid -> print_module qid
-  | PrintModuleType qid -> print_modtype qid
-  | PrintNamespace ns -> print_namespace ns
-  | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ())
-  | PrintMLModules -> msg_notice (Mltop.print_ml_modules ())
-  | PrintDebugGC -> msg_notice (Mltop.print_gc ())
-  | PrintName qid -> dump_global qid; msg_notice (print_name qid)
-  | PrintGraph -> msg_notice (Prettyp.print_graph())
-  | PrintClasses -> msg_notice (Prettyp.print_classes())
-  | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses())
-  | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c))
-  | PrintCoercions -> msg_notice (Prettyp.print_coercions())
-  | PrintCoercionPaths (cls,clt) ->
-      msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
-  | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ())
-  | PrintUniverses (b, dst) ->
-     let univ = Global.universes () in
-     let univ = if b then UGraph.sort_universes univ else univ in
-     let pr_remaining =
-       if Global.is_joined_environment () then mt ()
-       else str"There may remain asynchronous universe constraints"
-     in
-     begin match dst with
-     | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
-     | Some s -> dump_universes_gen univ s
-     end
-  | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r))
-  | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ())
-  | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s)
-  | PrintHintDb -> msg_notice (Hints.pr_searchtable ())
-  | PrintScopes ->
-      msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
-  | PrintScope s ->
-      msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s)
-  | PrintVisibility s ->
-      msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
-  | PrintAbout (ref_or_by_not,glnumopt) ->
-     msg_notice (print_about_hyp_globs ref_or_by_not glnumopt)
-  | PrintImplicit qid ->
-    dump_global qid; msg_notice (print_impargs qid)
-  | PrintAssumptions (o,t,r) ->
-      (* Prints all the axioms and section variables used by a term *)
-      let gr = smart_global r in
-      let cstr = printable_constr_of_global gr in
-      let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in
-      let nassums =
-	Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in
-      msg_notice (Printer.pr_assumptionset (Global.env ()) nassums)
-  | PrintStrategy r -> print_strategy r
-
-let global_module r =
-  let (loc,qid) = qualid_of_reference r in
-  try Nametab.full_name_module qid
-  with Not_found ->
-    user_err_loc (loc, "global_module",
-      str "Module/section " ++ pr_qualid qid ++ str " not found.")
-
-let interp_search_restriction = function
-  | SearchOutside l -> (List.map global_module l, true)
-  | SearchInside l -> (List.map global_module l, false)
-
-open Search
-
-let interp_search_about_item env =
-  function
-  | SearchSubPattern pat ->
-      let _,pat = intern_constr_pattern env pat in
-      GlobSearchSubPattern pat
-  | SearchString (s,None) when Id.is_valid s ->
-      GlobSearchString s
-  | SearchString (s,sc) ->
-      try
-	let ref =
-	  Notation.interp_notation_as_global_reference Loc.ghost
-	    (fun _ -> true) s sc in
-	GlobSearchSubPattern (Pattern.PRef ref)
-      with UserError _ ->
-	errorlabstrm "interp_search_about_item"
-          (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component")
-
-(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the
-   `search_output_name_only` option to avoid excessive printing when
-   searching.
-
-   The motivation was to make search usable for IDE completion,
-   however, it is still too slow due to the non-indexed nature of the
-   underlying search mechanism.
-
-   In the future we should deprecate the option and provide a fast,
-   indexed name-searching interface.
-*)
-let search_output_name_only = ref false
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "output-name-only search";
-      optkey   = ["Search";"Output";"Name";"Only"];
-      optread  = (fun () -> !search_output_name_only);
-      optwrite = (:=) search_output_name_only }
-
-let vernac_search s gopt r =
-  let r = interp_search_restriction r in
-  let env,gopt =
-    match gopt with | None ->
-      (* 1st goal by default if it exists, otherwise no goal at all *)
-      (try snd (Pfedit.get_goal_context 1) , Some 1
-       with _ -> Global.env (),None)
-    (* if goal selector is given and wrong, then let exceptions be raised. *)
-    | Some g -> snd (Pfedit.get_goal_context g) , Some g
-  in
-  let get_pattern c = snd (intern_constr_pattern env c) in
-  let pr_search ref env c =
-    let pr = pr_global ref in
-    let pp = if !search_output_name_only
-      then pr
-      else begin
-        let pc = pr_lconstr_env env Evd.empty c in
-        hov 2 (pr ++ str":" ++ spc () ++ pc)
-      end
-    in Feedback.msg_notice pp
-  in
-  match s with
-  | SearchPattern c ->
-      Search.search_pattern gopt (get_pattern c) r pr_search
-  | SearchRewrite c ->
-      Search.search_rewrite gopt (get_pattern c) r pr_search
-  | SearchHead c ->
-      Search.search_by_head gopt (get_pattern c) r pr_search
-  | SearchAbout sl ->
-      Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r pr_search
-
-let vernac_locate = let open Feedback in function
-  | LocateAny (AN qid)  -> msg_notice (print_located_qualid qid)
-  | LocateTerm (AN qid) -> msg_notice (print_located_term qid)
-  | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *)
-  | LocateTerm (ByNotation (_, ntn, sc)) ->
-      msg_notice
-        (Notation.locate_notation
-          (Constrextern.without_symbols pr_lglob_constr) ntn sc)
-  | LocateLibrary qid -> print_located_library qid
-  | LocateModule qid -> msg_notice (print_located_module qid)
-  | LocateTactic qid -> msg_notice (print_located_tactic qid)
-  | LocateFile f -> msg_notice (locate_file f)
-
-let vernac_register id r =
- if Pfedit.refining () then
-    error "Cannot register a primitive while in proof editing mode.";
-  let t = (Constrintern.global_reference (snd id)) in
-  if not (isConst t) then
-    error "Register inline: a constant is expected";
-  let kn = destConst t in
-  match r with
-  | RegisterInline -> Global.register_inline (Univ.out_punivs kn)
-
-(********************)
-(* Proof management *)
-
-let vernac_focus gln =
-  Proof_global.simple_with_current_proof (fun _ p ->
-    match gln with
-      | None -> Proof.focus focus_command_cond () 1 p
-      | Some 0 ->
-         CErrors.error "Invalid goal number: 0. Goal numbering starts with 1."
-      | Some n ->
-         Proof.focus focus_command_cond () n p)
-
-  (* Unfocuses one step in the focus stack. *)
-let vernac_unfocus () =
-  Proof_global.simple_with_current_proof
-    (fun _ p -> Proof.unfocus command_focus p ())
-
-(* Checks that a proof is fully unfocused. Raises an error if not. *)
-let vernac_unfocused () =
-  let p = Proof_global.give_me_the_proof () in
-  if Proof.unfocused p then
-    Feedback.msg_notice (str"The proof is indeed fully unfocused.")
-  else
-    error "The proof is not fully unfocused."
-
-
-(* BeginSubproof / EndSubproof. 
-    BeginSubproof (vernac_subproof) focuses on the first goal, or the goal
-    given as argument.
-    EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided
-    that the proof of the goal has been completed.
-*)
-let subproof_kind = Proof.new_focus_kind ()
-let subproof_cond = Proof.done_cond subproof_kind
-
-let vernac_subproof gln =
-  Proof_global.simple_with_current_proof (fun _ p ->
-    match gln with
-    | None -> Proof.focus subproof_cond () 1 p
-    | Some n -> Proof.focus subproof_cond () n p)
-
-let vernac_end_subproof () =
-  Proof_global.simple_with_current_proof (fun _ p ->
-    Proof.unfocus subproof_kind p ())
-
-let vernac_bullet (bullet:Proof_global.Bullet.t) =
-  Proof_global.simple_with_current_proof (fun _ p ->
-    Proof_global.Bullet.put p bullet)
-
-let vernac_show = let open Feedback in function
-  | ShowGoal goalref ->
-    let info = match goalref with
-      | OpenSubgoals -> pr_open_subgoals ()
-      | NthGoal n -> pr_nth_open_subgoal n
-      | GoalId id -> pr_goal_by_id id
-      | GoalUid id -> pr_goal_by_uid id
-    in
-    msg_notice info
-  | ShowGoalImplicitly None ->
-      Constrextern.with_implicits msg_notice (pr_open_subgoals ())
-  | ShowGoalImplicitly (Some n) ->
-      Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n)
-  | ShowProof -> show_proof ()
-  | ShowNode -> show_node ()
-  | ShowScript -> Stm.show_script ()
-  | ShowExistentials -> show_top_evars ()
-  | ShowUniverses -> show_universes ()
-  | ShowTree -> show_prooftree ()
-  | ShowProofNames ->
-      msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names()))
-  | ShowIntros all -> show_intro all
-  | ShowMatch id -> show_match id
-  | ShowThesis -> show_thesis ()
-
-
-let vernac_check_guard () =
-  let pts = get_pftreestate () in
-  let pfterm = List.hd (Proof.partial_proof pts) in
-  let message =
-    try
-      let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in
-      Inductiveops.control_only_guard (Goal.V82.env sigma gl)
-	pfterm;
-      (str "The condition holds up to here")
-    with UserError(_,s) ->
-      (str ("Condition violated: ") ++s)
-  in
-  Feedback.msg_notice message
-
-exception End_of_input
-
-let vernac_load interp fname =
-  let interp x =
-    let proof_mode = Proof_global.get_default_proof_mode_name () in
-    Proof_global.activate_proof_mode proof_mode;
-    interp x in
-  let parse_sentence = Flags.with_option Flags.we_are_parsing
-    (fun po ->
-    match Pcoq.Gram.entry_parse Pcoq.main_entry po with
-      | Some x -> x
-      | None -> raise End_of_input) in
-  let fname =
-    Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
-  let fname = CUnix.make_suffix fname ".v" in
-  let input =
-    let longfname = Loadpath.locate_file fname in
-    let in_chan = open_utf8_file_in longfname in
-    Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in
-  try while true do interp (snd (parse_sentence input)) done
-  with End_of_input -> ()
-
-(* "locality" is the prefix "Local" attribute, while the "local" component
- * is the outdated/deprecated "Local" attribute of some vernacular commands
- * still parsed as the obsolete_locality grammar entry for retrocompatibility.
- * loc is the Loc.t of the vernacular command being interpreted. *)
-let interp ?proof ~loc locality poly c =
-  prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
-  match c with
-  (* Done later in this file *)
-  | VernacLoad _ -> assert false
-  | VernacFail _ -> assert false
-  | VernacTime _ -> assert false
-  | VernacRedirect _ -> assert false
-  | VernacTimeout _ -> assert false
-  | VernacStm _ -> assert false
-
-  | VernacError e -> raise e
-
-  (* Syntax *)
-  | VernacSyntaxExtension (local,sl) ->
-      vernac_syntax_extension locality local sl
-  | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
-  | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
-  | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s
-  | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl
-  | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc
-  | VernacNotation (local,c,infpl,sc) ->
-      vernac_notation locality local c infpl sc
-  | VernacNotationAddFormat(n,k,v) ->
-      Metasyntax.add_notation_extra_printing_rule n k v
-
-  (* Gallina *)
-  | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d
-  | VernacStartTheoremProof (k,l,top) -> vernac_start_proof locality poly k l top
-  | VernacEndProof e -> vernac_end_proof ?proof e
-  | VernacExactProof c -> vernac_exact_proof c
-  | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl
-  | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l
-  | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l
-  | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l
-  | VernacScheme l -> vernac_scheme l
-  | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l
-  | VernacUniverse l -> vernac_universe loc poly l
-  | VernacConstraint l -> vernac_constraint loc poly l
-
-  (* Modules *)
-  | VernacDeclareModule (export,lid,bl,mtyo) ->
-      vernac_declare_module export lid bl mtyo
-  | VernacDefineModule (export,lid,bl,mtys,mexprl) ->
-      vernac_define_module export lid bl mtys mexprl
-  | VernacDeclareModuleType (lid,bl,mtys,mtyo) ->
-      vernac_declare_module_type lid bl mtys mtyo
-  | VernacInclude in_asts ->
-      vernac_include in_asts
-  (* Gallina extensions *)
-  | VernacBeginSection lid -> vernac_begin_section lid
-
-  | VernacEndSegment lid -> vernac_end_segment lid
-
-  | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set
-
-  | VernacRequire (from, export, qidl) -> vernac_require from export qidl
-  | VernacImport (export,qidl) -> vernac_import export qidl
-  | VernacCanonical qid -> vernac_canonical qid
-  | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t
-  | VernacIdentityCoercion (local,(_,id),s,t) ->
-      vernac_identity_coercion locality poly local id s t
-
-  (* Type classes *)
-  | VernacInstance (abst, sup, inst, props, info) ->
-      vernac_instance abst locality poly sup inst props info
-  | VernacContext sup -> vernac_context poly sup
-  | VernacDeclareInstances insts -> vernac_declare_instances locality insts
-  | VernacDeclareClass id -> vernac_declare_class id
-
-  (* Solving *)
-  | VernacSolveExistential (n,c) -> vernac_solve_existential n c
-
-  (* Auxiliary file and library management *)
-  | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
-  | VernacRemoveLoadPath s -> vernac_remove_loadpath s
-  | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
-  | VernacDeclareMLModule l -> vernac_declare_ml_module locality l
-  | VernacChdir s -> vernac_chdir s
-
-  (* State management *)
-  | VernacWriteState s -> vernac_write_state s
-  | VernacRestoreState s -> vernac_restore_state s
-
-  (* Resetting *)
-  | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm")
-  | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
-  | VernacBack _ -> anomaly (str "VernacBack not handled by Stm")
-  | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
-
-  (* Commands *)
-  | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b
-  | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids
-  | VernacHints (local,dbnames,hints) ->
-      vernac_hints locality poly local dbnames hints
-  | VernacSyntacticDefinition (id,c,local,b) ->
-      vernac_syntactic_definition locality  id c local b
-  | VernacDeclareImplicits (qid,l) ->
-      vernac_declare_implicits locality qid l
-  | VernacArguments (qid, args, more_implicits, nargs, flags) ->
-      vernac_arguments locality qid args more_implicits nargs flags
-  | VernacReserve bl -> vernac_reserve bl
-  | VernacGeneralizable gen -> vernac_generalizable locality gen
-  | VernacSetOpacity qidl -> vernac_set_opacity locality qidl
-  | VernacSetStrategy l -> vernac_set_strategy locality l
-  | VernacSetOption (key,v) -> vernac_set_option locality key v
-  | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v
-  | VernacUnsetOption key -> vernac_unset_option locality key
-  | VernacRemoveOption (key,v) -> vernac_remove_option key v
-  | VernacAddOption (key,v) -> vernac_add_option key v
-  | VernacMemOption (key,v) -> vernac_mem_option key v
-  | VernacPrintOption key -> vernac_print_option key
-  | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
-  | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r
-  | VernacGlobalCheck c -> vernac_global_check c
-  | VernacPrint p -> vernac_print p
-  | VernacSearch (s,g,r) -> vernac_search s g r
-  | VernacLocate l -> vernac_locate l
-  | VernacRegister (id, r) -> vernac_register id r
-  | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n")
-
-  (* The STM should handle that, but LOAD bypasses the STM... *)
-  | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command")
-  | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command")
-  | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command")
-  | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command")
-  | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command")
-  | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command")
-  
-  (* Proof management *)
-  | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false
-  | VernacFocus n -> vernac_focus n
-  | VernacUnfocus -> vernac_unfocus ()
-  | VernacUnfocused -> vernac_unfocused ()
-  | VernacBullet b -> vernac_bullet b
-  | VernacSubproof n -> vernac_subproof n
-  | VernacEndSubproof -> vernac_end_subproof ()
-  | VernacShow s -> vernac_show s
-  | VernacCheckGuard -> vernac_check_guard ()
-  | VernacProof (None, None) ->
-      Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:no"
-  | VernacProof (Some tac, None) ->
-      Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:no";
-      vernac_set_end_tac tac
-  | VernacProof (None, Some l) ->
-      Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:yes";
-      vernac_set_used_variables l
-  | VernacProof (Some tac, Some l) -> 
-      Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes";
-      vernac_set_end_tac tac; vernac_set_used_variables l
-  | VernacProofMode mn -> Proof_global.set_proof_mode mn
-  (* Toplevel control *)
-  | VernacToplevelControl e -> raise e
-
-  (* Extensions *)
-  | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args)
-
-  (* Handled elsewhere *)
-  | VernacProgram _
-  | VernacPolymorphic _
-  | VernacLocal _ -> assert false
-
-(* Vernaculars that take a locality flag *)
-let check_vernac_supports_locality c l =
-  match l, c with
-  | None, _ -> ()
-  | Some _, (
-      VernacOpenCloseScope _
-    | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _
-    | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
-    | VernacAssumption _ | VernacStartTheoremProof _
-    | VernacCoercion _ | VernacIdentityCoercion _
-    | VernacInstance _ | VernacDeclareInstances _
-    | VernacDeclareMLModule _
-    | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
-    | VernacSyntacticDefinition _
-    | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _
-    | VernacGeneralizable _
-    | VernacSetOpacity _ | VernacSetStrategy _
-    | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _
-    | VernacDeclareReduction _
-    | VernacExtend _ 
-    | VernacInductive _) -> ()
-  | Some _, _ -> CErrors.error "This command does not support Locality"
-
-(* Vernaculars that take a polymorphism flag *)
-let check_vernac_supports_polymorphism c p =
-  match p, c with
-  | None, _ -> ()
-  | Some _, (
-      VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
-    | VernacAssumption _ | VernacInductive _ 
-    | VernacStartTheoremProof _
-    | VernacCoercion _ | VernacIdentityCoercion _
-    | VernacInstance _ | VernacDeclareInstances _
-    | VernacHints _ | VernacContext _
-    | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> ()
-  | Some _, _ -> CErrors.error "This command does not support Polymorphism"
-
-let enforce_polymorphism = function
-  | None -> Flags.is_universe_polymorphism ()
-  | Some b -> Flags.make_polymorphic_flag b; b
-
-(** A global default timeout, controlled by option "Set Default Timeout n".
-    Use "Unset Default Timeout" to deactivate it (or set it to 0). *)
-
-let default_timeout = ref None
-
-let _ =
-  Goptions.declare_int_option
-    { Goptions.optsync  = true;
-      Goptions.optdepr  = false;
-      Goptions.optname  = "the default timeout";
-      Goptions.optkey   = ["Default";"Timeout"];
-      Goptions.optread  = (fun () -> !default_timeout);
-      Goptions.optwrite = ((:=) default_timeout) }
-
-(** When interpreting a command, the current timeout is initially
-    the default one, but may be modified locally by a Timeout command. *)
-
-let current_timeout = ref None
-
-let vernac_timeout f =
-  match !current_timeout, !default_timeout with
-    | Some n, _ | None, Some n ->
-      let f () = f (); current_timeout := None in
-      Control.timeout n f Timeout
-    | None, None -> f ()
-
-let restore_timeout () = current_timeout := None
-
-let locate_if_not_already loc (e, info) =
-  match Loc.get_loc info with
-  | None -> (e, Loc.add_loc info loc)
-  | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info)
-
-exception HasNotFailed
-exception HasFailed of std_ppcmds
-
-let with_fail b f =
-  if not b then f ()
-  else begin try
-      (* If the command actually works, ignore its effects on the state.
-       * Note that error has to be printed in the right state, hence
-       * within the purified function *)
-      Future.purify
-        (fun v ->
-           try f v; raise HasNotFailed
-           with
-           | HasNotFailed as e -> raise e
-           | e ->
-              let e = CErrors.push e in
-              raise (HasFailed (CErrors.iprint
-                (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e))))
-        ()
-    with e when CErrors.noncritical e ->
-      let (e, _) = CErrors.push e in
-      match e with
-      | HasNotFailed ->
-          errorlabstrm "Fail" (str "The command has not failed!")
-      | HasFailed msg ->
-          if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info
-            (str "The command has indeed failed with message:" ++ fnl () ++ msg)
-      | _ -> assert false
-  end
-
-let interp ?(verbosely=true) ?proof (loc,c) =
-  let orig_program_mode = Flags.is_program_mode () in
-  let rec aux ?locality ?polymorphism isprogcmd = function
-    | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c
-    | VernacProgram _ -> CErrors.error "Program mode specified twice"
-    | VernacLocal (b, c) when Option.is_empty locality -> 
-      aux ~locality:b ?polymorphism isprogcmd c
-    | VernacPolymorphic (b, c) when polymorphism = None -> 
-      aux ?locality ~polymorphism:b isprogcmd c
-    | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice"
-    | VernacLocal _ -> CErrors.error "Locality specified twice"
-    | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c
-    | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c
-    | VernacStm _ -> assert false (* Done by Stm *)
-    | VernacFail v ->
-        with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v)
-    | VernacTimeout (n,v) ->
-        current_timeout := Some n;
-        aux ?locality ?polymorphism isprogcmd v
-    | VernacRedirect (s, (_,v)) ->
-         Feedback.with_output_to_file s (aux false) v
-    | VernacTime (_,v) ->
-        System.with_time !Flags.time
-          (aux ?locality ?polymorphism isprogcmd) v;
-    | VernacLoad (_,fname) -> vernac_load (aux false) fname
-    | c -> 
-        check_vernac_supports_locality c locality;
-        check_vernac_supports_polymorphism c polymorphism;
-	let poly = enforce_polymorphism polymorphism in
-        Obligations.set_program_mode isprogcmd;
-        try
-          vernac_timeout begin fun () ->
-          if verbosely
-            then Flags.verbosely (interp ?proof ~loc locality poly) c
-            else Flags.silently  (interp ?proof ~loc locality poly) c;
-          if orig_program_mode || not !Flags.program_mode || isprogcmd then
-            Flags.program_mode := orig_program_mode;
-	  ignore (Flags.use_polymorphic_flag ())
-          end
-        with
-        | reraise when
-              (match reraise with
-              | Timeout -> true
-              | e -> CErrors.noncritical e)
-          ->
-            let e = CErrors.push reraise in
-            let e = locate_if_not_already loc e in
-            let () = restore_timeout () in
-            Flags.program_mode := orig_program_mode;
-	    ignore (Flags.use_polymorphic_flag ());
-            iraise e
-  in
-    if verbosely then Flags.verbosely (aux false) c
-    else aux false c
-
-let () = Hook.set Stm.interp_hook interp
-let () = Hook.set Stm.with_fail_hook with_fail
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
deleted file mode 100644
index 4e7fa4a0..00000000
--- a/toplevel/vernacentries.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Misctypes
-
-val dump_global : Libnames.reference or_by_notation -> unit
-
-(** Vernacular entries *)
-
-val show_prooftree : unit -> unit
-
-val show_node : unit -> unit
-
-val vernac_require :
-  Libnames.reference option -> bool option -> Libnames.reference list -> unit
-
-(** This function can be used by any command that want to observe terms
-   in the context of the current goal *)
-val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
-
-(** The main interpretation function of vernacular expressions *)
-val interp : 
-  ?verbosely:bool ->
-  ?proof:Proof_global.closed_proof ->
-    Loc.t * Vernacexpr.vernac_expr -> unit
-
-(** Print subgoals when the verbose flag is on.
-    Meant to be used inside vernac commands from plugins. *)
-
-val print_subgoals : unit -> unit
-val try_print_subgoals : unit -> unit
-
-(** The printing of goals via [print_subgoals] or during
-    [interp] can be controlled by the following flag.
-    Used for instance by coqide, since it has its own
-    goal-fetching mechanism. *)
-
-val enable_goal_printing : bool ref
-
-(** Should Qed try to display the proof script ?
-    True by default, but false in ProofGeneral and coqIDE *)
-
-val qed_display_script : bool ref
-
-(** Prepare a "match" template for a given inductive type.
-    For each branch of the match, we list the constructor name
-    followed by enough pattern variables.
-    [Not_found] is raised if the given string isn't the qualid of
-    a known inductive type. *)
-
-val make_cases : string -> string list list
-
-val vernac_end_proof :
-  ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit
-
-val with_fail : bool -> (unit -> unit) -> unit
-
-val command_focus : unit Proof.focus_kind
-
-val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr ->
-  Evd.evar_map * Redexpr.red_expr) Hook.t
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
deleted file mode 100644
index d81e3d6b..00000000
--- a/toplevel/vernacinterp.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Pp
-open CErrors
-
-type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
-
-(* Table of vernac entries *)
-let vernac_tab =
-  (Hashtbl.create 51 :
-    (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t)
-
-let vinterp_add depr s f =
-  try
-    Hashtbl.add vernac_tab s (depr, f)
-  with Failure _ ->
-    errorlabstrm "vinterp_add"
-      (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.")
-
-let overwriting_vinterp_add s f =
-  begin
-    try
-      let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s
-    with Not_found -> ()
-  end;
-  Hashtbl.add vernac_tab s (false, f)
-
-let vinterp_map s =
-  try
-    Hashtbl.find vernac_tab s
-  with Failure _ | Not_found ->
-    errorlabstrm "Vernac Interpreter"
-      (str"Cannot find vernac command " ++ str (fst s) ++ str".")
-
-let vinterp_init () = Hashtbl.clear vernac_tab
-
-let warn_deprecated_command =
-  let open CWarnings in
-  create ~name:"deprecated-command" ~category:"deprecated"
-         (fun pr -> str "Deprecated vernacular command: " ++ pr)
-
-(* Interpretation of a vernac command *)
-
-let call ?locality (opn,converted_args) =
-  let loc = ref "Looking up command" in
-  try
-    let depr, callback = vinterp_map opn in
-    let () = if depr then
-      let rules = Egramml.get_extend_vernac_rule opn in
-      let pr_gram = function
-      | Egramml.GramTerminal s -> str s
-      | Egramml.GramNonTerminal _ -> str "_"
-      in
-      let pr = pr_sequence pr_gram rules in
-      warn_deprecated_command pr;
-    in
-    loc:= "Checking arguments";
-    let hunk = callback converted_args in
-    loc:= "Executing command";
-    Locality.LocalityFixme.set locality;
-    hunk();
-    Locality.LocalityFixme.assert_consumed()
-  with
-    | Drop -> raise Drop
-    | reraise ->
-        let reraise = CErrors.push reraise in
-        if !Flags.debug then
-	  Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc);
-        iraise reraise
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
deleted file mode 100644
index 5149b541..00000000
--- a/toplevel/vernacinterp.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Interpretation of extended vernac phrases. *)
-
-type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
-
-val vinterp_add : deprecation -> Vernacexpr.extend_name ->
-  vernac_command -> unit
-val overwriting_vinterp_add :
-  Vernacexpr.extend_name -> vernac_command -> unit
-
-val vinterp_init : unit -> unit
-val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit