Imported Upstream version 8.9.0upstream/8.9.0upstream

55 files changed, 5460 insertions, 850 deletions

diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli
index 7e13f8f2..751e79d8 100644
--- a/vernac/assumptions.mli
+++ b/vernac/assumptions.mli
@@ -23,11 +23,11 @@ open Printer
 val traverse :
   Label.t -> constr ->
     (Refset_env.t * Refset_env.t Refmap_env.t *
-     (Label.t * Context.Rel.t * types) list Refmap_env.t)
+     (Label.t * Constr.rel_context * 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 -> types ContextObjectMap.t
+     GlobRef.t -> constr -> types ContextObjectMap.t
diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml
index 0404d015..3bf3925b 100644
--- a/vernac/auto_ind_decl.ml
+++ b/vernac/auto_ind_decl.ml
@@ -24,7 +24,8 @@ open Globnames
 open Inductiveops
 open Tactics
 open Ind_tables
-open Misctypes
+open Namegen
+open Tactypes
 open Proofview.Notations
 
 module RelDecl = Context.Rel.Declaration
@@ -54,20 +55,20 @@ exception EqUnknown of string
 exception UndefinedCst of string
 exception InductiveWithProduct
 exception InductiveWithSort
-exception ParameterWithoutEquality of global_reference
+exception ParameterWithoutEquality of GlobRef.t
 exception NonSingletonProp of inductive
 exception DecidabilityMutualNotSupported
 exception NoDecidabilityCoInductive
 
-let constr_of_global g = lazy (Universes.constr_of_global g)
+let constr_of_global g = lazy (UnivGen.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 _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop
+let andb_prop = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop
 
 let andb_true_intro = fun _ ->
-  Universes.constr_of_global
+  UnivGen.constr_of_global
     (Coqlib.build_bool_type()).Coqlib.andb_true_intro
 
 let tt = constr_of_global Coqlib.glob_true
@@ -76,9 +77,9 @@ let ff = constr_of_global Coqlib.glob_false
 
 let eq = constr_of_global Coqlib.glob_eq
 
-let sumbool () = Universes.constr_of_global (Coqlib.build_coq_sumbool ())
+let sumbool () = UnivGen.constr_of_global (Coqlib.build_coq_sumbool ())
 
-let andb = fun _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb
+let andb = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb
 
 let induct_on c = induction false None c None None
 
@@ -186,10 +187,10 @@ let build_beq_scheme mode kn =
     *)
     let compute_A_equality rel_list nlist eqA ndx t =
       let lifti = ndx in
-      let sigma = Evd.empty (** FIXME *) in
       let rec aux c =
-	let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
-	match EConstr.kind sigma c with
+        let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in
+        let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in
+        match Constr.kind c with
         | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants
         | Var x ->
           let eid = Id.of_string ("eq_"^(Id.to_string x)) in
@@ -198,7 +199,7 @@ let build_beq_scheme mode kn =
             with Not_found -> raise (ParameterWithoutEquality (VarRef x))
           in
           mkVar eid, Safe_typing.empty_private_constants
-        | Cast (x,_,_) -> aux (EConstr.applist (x,a))
+        | Cast (x,_,_) -> aux (Term.applist (x,a))
         | App _ -> assert false
         | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> 
             if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants
@@ -213,8 +214,8 @@ let build_beq_scheme mode kn =
                   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 (EConstr.Unsafe.to_constr x)) a)) eqa in
+                  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))
@@ -224,10 +225,9 @@ let build_beq_scheme mode kn =
         | Lambda _-> raise (EqUnknown "abstraction")
         | LetIn _ -> raise (EqUnknown "let-in")
         | Const (kn, u) ->
-            let u = EConstr.EInstance.kind sigma u in
 	    (match Environ.constant_opt_value_in env (kn, u) with
 	      | None -> raise (ParameterWithoutEquality (ConstRef kn))
-	      | Some c -> aux (EConstr.applist (EConstr.of_constr c,a)))
+              | Some c -> aux (Term.applist (c,a)))
         | Proj _ -> raise (EqUnknown "projection")
         | Construct _ -> raise (EqUnknown "constructor")
         | Case _ -> raise (EqUnknown "match")
@@ -271,7 +271,7 @@ let build_beq_scheme mode kn =
                                           nparrec
                                           (nparrec+3+2*nb_cstr_args)
                                           (nb_cstr_args+ndx+1)
-                                          (EConstr.of_constr cc)
+                                          cc
                           in
                           eff := Safe_typing.concat_private eff' !eff;
                           Array.set eqs ndx
@@ -408,9 +408,9 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
        lb_type_of_p >>= fun (lb_type_of_p,eff) ->
        Proofview.tclEVARMAP >>= fun sigma ->
        let lb_args = Array.append (Array.append
-                          (Array.map (fun x -> x) v)
-                          (Array.map (fun x -> do_arg sigma x 1) v))
-                          (Array.map (fun x -> do_arg sigma x 2) v)
+                          v
+                          (Array.Smart.map (fun x -> do_arg sigma x 1) v))
+                          (Array.Smart.map (fun x -> do_arg sigma x 2) v)
         in let app =  if Array.is_empty lb_args
                        then lb_type_of_p else mkApp (lb_type_of_p,lb_args)
            in
@@ -479,9 +479,9 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
 		 user_err err_msg
                in let bl_args =
                         Array.append (Array.append
-                          (Array.map (fun x -> x) v)
-                          (Array.map (fun x -> do_arg sigma x 1) v))
-                          (Array.map (fun x -> do_arg sigma x 2) v )
+                          v
+                          (Array.Smart.map (fun x -> do_arg sigma x 1) v))
+                          (Array.Smart.map (fun x -> do_arg sigma x 2) v )
                 in
                 let app =  if Array.is_empty bl_args
                            then bl_t1 else mkApp (bl_t1,bl_args)
@@ -543,7 +543,7 @@ let eqI ind l =
   and e, eff = 
     try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff 
     with Not_found -> user_err ~hdr:"AutoIndDecl.eqI"
-      (str "The boolean equality on " ++ MutInd.print (fst ind) ++ str " is needed.");
+      (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed.");
   in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)), eff
 
 (**********************************************************************)
@@ -643,7 +643,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
                         | App (c,ca) -> (
                           match EConstr.kind sigma c with
                           | Ind (indeq, u) ->
-                              if eq_gr (IndRef indeq) Coqlib.glob_eq
+                              if GlobRef.equal (IndRef indeq) Coqlib.glob_eq
                               then
                                 Tacticals.New.tclTHEN
                                   (do_replace_bl mode bl_scheme_key ind
@@ -871,7 +871,7 @@ let compute_dec_goal ind lnamesparrec nparrec =
         create_input (
           mkNamedProd n (mkFullInd ind (2*nparrec)) (
             mkNamedProd m (mkFullInd ind (2*nparrec+1)) (
-              mkApp(sumbool(),[|eqnm;mkApp (Universes.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|])
+              mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|])
           )
         )
       )
@@ -931,7 +931,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
 	    (* left *)
 	    Tacticals.New.tclTHENLIST [
 	      simplest_left;
-              apply (EConstr.of_constr (mkApp(blI,Array.map(fun x->mkVar x) xargs)));
+              apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs)));
               Auto.default_auto
             ]
             ;
@@ -947,7 +947,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
               assert_by (Name freshH3)
 		(EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])))
 		(Tacticals.New.tclTHENLIST [
-		  apply (EConstr.of_constr (mkApp(lbI,Array.map (fun x->mkVar x) xargs)));
+                  apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs)));
                   Auto.default_auto
 		]);
 	      Equality.general_rewrite_bindings_in true
diff --git a/vernac/auto_ind_decl.mli b/vernac/auto_ind_decl.mli
index 5cc783df..11f26c7c 100644
--- a/vernac/auto_ind_decl.mli
+++ b/vernac/auto_ind_decl.mli
@@ -23,7 +23,7 @@ exception EqUnknown of string
 exception UndefinedCst of string
 exception InductiveWithProduct
 exception InductiveWithSort
-exception ParameterWithoutEquality of Globnames.global_reference
+exception ParameterWithoutEquality of GlobRef.t
 exception NonSingletonProp of inductive
 exception DecidabilityMutualNotSupported
 exception NoDecidabilityCoInductive
diff --git a/vernac/class.ml b/vernac/class.ml
index 59d93310..614b2181 100644
--- a/vernac/class.ml
+++ b/vernac/class.ml
@@ -37,7 +37,7 @@ type coercion_error_kind =
   | ForbiddenSourceClass of cl_typ
   | NoTarget
   | WrongTarget of cl_typ * cl_typ
-  | NotAClass of global_reference
+  | NotAClass of GlobRef.t
 
 exception CoercionError of coercion_error_kind
 
@@ -67,13 +67,13 @@ let explain_coercion_error g = function
 let check_reference_arity ref =
   let env = Global.env () in
   let c, _ = Global.type_of_global_in_context env ref in
-  if not (Reductionops.is_arity env Evd.empty (EConstr.of_constr c)) (** FIXME *) then
+  if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (** FIXME *) 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_PROJ p -> check_reference_arity (ConstRef (Projection.Repr.constant p))
   | CL_SECVAR id -> check_reference_arity (VarRef id)
   | CL_IND kn -> check_reference_arity (IndRef kn)
 
@@ -92,8 +92,8 @@ let uniform_cond sigma ctx lt =
 
 let class_of_global = function
   | ConstRef sp -> 
-    if Environ.is_projection sp (Global.env ()) 
-    then CL_PROJ sp else CL_CONST sp
+    (match Recordops.find_primitive_projection sp with
+     | Some p -> CL_PROJ p | None -> CL_CONST sp)
   | IndRef sp -> CL_IND sp
   | VarRef id -> CL_SECVAR id
   | ConstructRef _ as c ->
@@ -143,8 +143,8 @@ let get_target t ind =
     CL_FUN
   else
     match pi1 (find_class_type Evd.empty (EConstr.of_constr t)) with
-    | CL_CONST p when Environ.is_projection p (Global.env ()) -> 
-      CL_PROJ p
+    | CL_CONST p when Recordops.is_primitive_projection p ->
+      CL_PROJ (Option.get @@ Recordops.find_primitive_projection p)
     | x -> x
       
 let strength_of_cl = function
@@ -165,7 +165,8 @@ let get_strength stre ref cls clt =
 let ident_key_of_class = function
   | CL_FUN -> "Funclass"
   | CL_SORT -> "Sortclass"
-  | CL_CONST sp | CL_PROJ sp -> Label.to_string (Constant.label sp)
+  | CL_CONST sp -> Label.to_string (Constant.label sp)
+  | CL_PROJ sp -> Label.to_string (Projection.Repr.label sp)
   | CL_IND (sp,_) -> Label.to_string (MutInd.label sp)
   | CL_SECVAR id -> Id.to_string id
 
@@ -181,6 +182,7 @@ let build_id_coercion idf_opt source poly =
   let sigma, vs = match source with
     | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp)
     | _ -> error_not_transparent source in
+  let vs = EConstr.Unsafe.to_constr vs in
   let c = match constant_opt_value_in env (destConst vs) with
     | Some c -> c
     | None -> error_not_transparent source in
@@ -302,12 +304,12 @@ 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
+  let local = match local with
+  | Discharge
   | Local -> true
   | Global -> false
-  | Discharge -> assert false
   in
-  let () = try_add_new_coercion ref ~local:stre poly in
+  let () = try_add_new_coercion ref ~local poly in
   let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in
   Flags.if_verbose Feedback.msg_info msg
 
diff --git a/vernac/class.mli b/vernac/class.mli
index 33d31fe1..f7e837f3 100644
--- a/vernac/class.mli
+++ b/vernac/class.mli
@@ -10,19 +10,18 @@
 
 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 -> 
+val try_add_new_coercion_with_target : GlobRef.t -> 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 -> 
+val try_add_new_coercion : GlobRef.t -> local:bool ->
   Decl_kinds.polymorphic -> unit
 
 (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
@@ -34,7 +33,7 @@ val try_add_new_coercion_subclass : cl_typ -> local:bool ->
 
 (** [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 -> 
+val try_add_new_coercion_with_source : GlobRef.t -> local:bool ->
   Decl_kinds.polymorphic -> source:cl_typ -> unit
 
 (** [try_add_new_identity_coercion id s src tg] enriches the
@@ -47,4 +46,4 @@ 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
+val class_of_global : GlobRef.t -> cl_typ
diff --git a/vernac/classes.ml b/vernac/classes.ml
index 76d427ad..e491761a 100644
--- a/vernac/classes.ml
+++ b/vernac/classes.ml
@@ -41,8 +41,8 @@ let _ = Goptions.declare_bool_option {
 let typeclasses_db = "typeclass_instances"
 
 let set_typeclass_transparency c local b = 
-  Hints.add_hints local [typeclasses_db] 
-    (Hints.HintsTransparencyEntry ([c], b))
+  Hints.add_hints ~local [typeclasses_db]
+    (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b))
     
 let _ =
   Hook.set Typeclasses.add_instance_hint_hook
@@ -50,24 +50,25 @@ let _ =
      let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr 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()) Evd.(from_env Global.(env())))
-		     info.hint_pattern } in
      Flags.silently (fun () ->
-	Hints.add_hints local [typeclasses_db]
+       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))
 
+let intern_info {hint_priority;hint_pattern} =
+  let env = Global.env() in
+  let sigma = Evd.from_env env in
+  let hint_pattern = Option.map (Constrintern.intern_constr_pattern env sigma) hint_pattern in
+  {hint_priority;hint_pattern}
+
 (** 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 info = intern_info info in
   let instance, _ = Global.type_of_global_in_context (Global.env ()) c in
   let _, r = Term.decompose_prod_assum instance in
     match class_of_constr Evd.empty (EConstr.of_constr r) with
@@ -76,8 +77,8 @@ let existing_instance glob g info =
                          ~hdr:"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
+let mismatched_params env n m = Implicit_quantifiers.mismatched_ctx_inst_err env Parameters n m
+let mismatched_props env n m = Implicit_quantifiers.mismatched_ctx_inst_err env Properties n m
 
 (* Declare everything in the parameters as implicit, and the class instance as well *)
 
@@ -108,15 +109,15 @@ open Pp
 
 let instance_hook k info global imps ?hook cst =
   Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
+  let info = intern_info info in
   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 decl poly sigma term termtype =
   let kind = IsDefinition Instance in
   let sigma =
-    let env = Global.env () in
-    let levels = Univ.LSet.union (Univops.universes_of_constr env termtype)
-                                 (Univops.universes_of_constr env term) in
+    let levels = Univ.LSet.union (Univops.universes_of_constr termtype)
+                                 (Univops.universes_of_constr term) in
     Evd.restrict_universe_context sigma levels
   in
   let uctx = Evd.check_univ_decl ~poly sigma decl in
@@ -135,7 +136,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
   ?(tac:unit Proofview.tactic option) ?hook pri =
   let env = Global.env() in
   let ({CAst.loc;v=instid}, pl) = instid in
-  let sigma, decl = Univdecls.interp_univ_decl_opt env pl in
+  let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in
   let tclass, ids =
     match bk with
     | Decl_kinds.Implicit ->
@@ -143,7 +144,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
 	  (fun avoid (clname, _) ->
 	    match clname with
             | Some cl ->
-		let t = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) in
+                let t = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) in
 		  t, avoid
 	    | None -> failwith ("new instance: under-applied typeclass"))
 	  cl
@@ -196,8 +197,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
 	in
 	let (_, ty_constr) = instance_constructor (k,u) subst in
         let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-        let sigma,_ = Evarutil.nf_evars_and_universes sigma in
-        Pretyping.check_evars env Evd.empty sigma termtype;
+        let sigma = Evd.minimize_universes sigma in
+        Pretyping.check_evars env (Evd.from_env env) sigma termtype;
         let univs = Evd.check_univ_decl ~poly sigma decl in
         let termtype = to_constr sigma termtype in
         let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id
@@ -227,10 +228,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
             let sigma, c = interp_casted_constr_evars env' sigma term cty in
             Some (Inr (c, subst)), sigma
 	| Some (Inl props) ->
-            let get_id = CAst.map (function
-                | Ident id' -> id'
-                | Qualid id' -> snd (repr_qualid id'))
-	    in
+            let get_id qid = CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid in
 	    let props, rest =
 	      List.fold_left
 		(fun (props, rest) decl ->
@@ -253,7 +251,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
 			   k.cl_projs;
 			 c :: props, rest'
 		     with Not_found ->
-		       ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None)) :: props), rest
+                       ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest
 		   else props, rest)
 		([], props) k.cl_props
 	    in
@@ -289,11 +287,11 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
       let sigma = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env sigma in
       let sigma = Evarutil.nf_evar_map_undefined sigma in
       (* Beware of this step, it is required as to minimize universes. *)
-      let sigma, _nf = Evarutil.nf_evar_map_universes sigma in
+      let sigma = Evd.minimize_universes sigma in
       (* Check that the type is free of evars now. *)
-      Pretyping.check_evars env Evd.empty sigma termtype;
+      Pretyping.check_evars env (Evd.from_env env) sigma termtype;
       let termtype = to_constr sigma termtype in
-      let term = Option.map (to_constr sigma) term in
+      let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in
         if not (Evd.has_undefined sigma) && not (Option.is_empty term) then
 	  declare_instance_constant k pri global imps ?hook id decl
             poly sigma (Option.get term) termtype
@@ -302,7 +300,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
             if 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];
+                  Impargs.declare_manual_implicits false gr ~enriching:false [imps];
+                  let pri = intern_info pri in
 		  Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst)
 	      in
 	      let obls, constr, typ =
@@ -365,8 +364,8 @@ let context poly l =
   let sigma = Evd.from_env env in
   let sigma, (_, ((env', fullctx), impls)) = interp_context_evars env sigma l in
   (* Note, we must use the normalized evar from now on! *)
-  let sigma,_ = Evarutil.nf_evars_and_universes sigma in
-  let ce t = Pretyping.check_evars env Evd.empty sigma t in
+  let sigma = Evd.minimize_universes sigma in
+  let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in
   let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in
   let ctx =
     try named_of_rel_context fullctx
@@ -424,13 +423,13 @@ let context poly l =
       let decl = (Discharge, poly, Definitional) in
       let nstatus = match b with
       | None ->
-        pi3 (ComAssumption.declare_assumption false decl (t, univs) Universes.empty_binders [] impl
-          Vernacexpr.NoInline (CAst.make id))
+        pi3 (ComAssumption.declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl
+               Declaremods.NoInline (CAst.make id))
       | Some b ->
         let decl = (Discharge, poly, Definition) in
         let entry = Declare.definition_entry ~univs ~types:t b in
         let hook = Lemmas.mk_hook (fun _ gr -> gr) in
-        let _ = DeclareDef.declare_definition id decl entry Universes.empty_binders [] hook in
+        let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] hook in
         Lib.sections_are_opened () || Lib.is_modtype_strict ()
       in
 	status && nstatus
diff --git a/vernac/classes.mli b/vernac/classes.mli
index 0342c840..9c37364c 100644
--- a/vernac/classes.mli
+++ b/vernac/classes.mli
@@ -16,23 +16,23 @@ open Libnames
 
 (** Errors *)
 
-val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a
+val mismatched_params : env -> constr_expr list -> Constr.rel_context -> 'a
 
-val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a
+val mismatched_props : env -> constr_expr list -> Constr.rel_context -> 'a
 
 (** Instance declaration *)
 
-val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit
+val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit
 (** globality, reference, optional priority and pattern information *)
 
 val declare_instance_constant :
   typeclass ->
-  Vernacexpr.hint_info_expr -> (** priority *)
+  Hints.hint_info_expr -> (** priority *)
   bool -> (** globality *)
   Impargs.manual_explicitation list -> (** implicits *)
-  ?hook:(Globnames.global_reference -> unit) ->
+  ?hook:(GlobRef.t -> unit) ->
   Id.t -> (** name *)
-  Univdecls.universe_decl ->
+  UState.universe_decl ->
   bool -> (* polymorphic *)
   Evd.evar_map -> (* Universes *)
   Constr.t -> (** body *)
@@ -50,8 +50,8 @@ val new_instance :
   (bool * constr_expr) option ->
   ?generalize:bool ->
   ?tac:unit Proofview.tactic  ->
-  ?hook:(Globnames.global_reference -> unit) ->
-  Vernacexpr.hint_info_expr ->
+  ?hook:(GlobRef.t -> unit) ->
+  Hints.hint_info_expr ->
   Id.t
 
 (** Setting opacity *)
diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml
index 6a590758..750ed35c 100644
--- a/vernac/comAssumption.ml
+++ b/vernac/comAssumption.ml
@@ -20,7 +20,6 @@ open Constrintern
 open Impargs
 open Decl_kinds
 open Pretyping
-open Vernacexpr
 open Entries
 
 (* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
@@ -66,7 +65,7 @@ match local with
 | Global | Local | Discharge ->
   let do_instance = should_axiom_into_instance local in
   let local = DeclareDef.get_locality ident ~kind:"axiom" local in
-  let inl = match nl with
+  let inl = let open Declaremods in match nl with
     | NoInline -> None
     | DefaultInline -> Some (Flags.get_inline_level())
     | InlineAt i -> Some i
@@ -137,7 +136,7 @@ let do_assumptions kind nl l =
   let open Context.Named.Declaration in
   let env = Global.env () in
   let udecl, l = process_assumptions_udecls kind l in
-  let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in
+  let sigma, udecl = interp_univ_decl_opt env udecl in
   let l =
     if pi2 kind (* poly *) then
       (* Separate declarations so that A B : Type puts A and B in different levels. *)
@@ -158,13 +157,13 @@ let do_assumptions kind nl l =
       ((sigma,env,ienv),((is_coe,idl),t,imps)))
     (sigma,env,empty_internalization_env) l
   in
-  let sigma = solve_remaining_evars all_and_fail_flags env sigma Evd.empty in
+  let sigma = solve_remaining_evars all_and_fail_flags env sigma (Evd.from_env env) in
   (* The universe constraints come from the whole telescope. *)
   let sigma = Evd.minimize_universes sigma in
   let nf_evar c = EConstr.to_constr sigma c in
   let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) ->
       let t = nf_evar t in
-      let uvars = Univ.LSet.union uvars (Univops.universes_of_constr env t) in
+      let uvars = Univ.LSet.union uvars (Univops.universes_of_constr t) in
       uvars, (coe,t,imps))
       Univ.LSet.empty l
   in
@@ -175,7 +174,7 @@ let do_assumptions kind nl l =
       let t = replace_vars subst t in
       let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in
       let subst' = List.map2
-          (fun {CAst.v=id} (c,u) -> (id, Universes.constr_of_global_univ (c,u)))
+          (fun {CAst.v=id} (c,u) -> (id, UnivGen.constr_of_global_univ (c,u)))
           idl refs
       in
       subst'@subst, status' && status, next_uctx uctx)
diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli
index 56e32437..56932360 100644
--- a/vernac/comAssumption.mli
+++ b/vernac/comAssumption.mli
@@ -11,7 +11,6 @@
 open Names
 open Constr
 open Entries
-open Globnames
 open Vernacexpr
 open Constrexpr
 open Decl_kinds
@@ -19,7 +18,7 @@ open Decl_kinds
 (** {6 Parameters/Assumptions} *)
 
 val do_assumptions : locality * polymorphic * assumption_object_kind ->
-  Vernacexpr.inline -> (ident_decl list * constr_expr) with_coercion list -> bool
+  Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool
 
 (************************************************************************)
 (** Internal API  *)
@@ -31,6 +30,6 @@ val do_assumptions : locality * polymorphic * assumption_object_kind ->
     nor in a module type and meant to be instantiated. *)
 val declare_assumption : coercion_flag -> assumption_kind ->
   types in_constant_universes_entry ->
-  Universes.universe_binders -> Impargs.manual_implicits ->
-  bool (** implicit *) -> Vernacexpr.inline -> variable CAst.t ->
-  global_reference * Univ.Instance.t * bool
+  UnivNames.universe_binders -> Impargs.manual_implicits ->
+  bool (** implicit *) -> Declaremods.inline -> variable CAst.t ->
+  GlobRef.t * Univ.Instance.t * bool
diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml
index b18a60a1..60f9d674 100644
--- a/vernac/comDefinition.ml
+++ b/vernac/comDefinition.ml
@@ -10,39 +10,19 @@
 
 open Pp
 open Util
-open Constr
-open Environ
 open Entries
 open Redexpr
 open Declare
 open Constrintern
 open Pretyping
 
-open Context.Rel.Declaration
-
 (* Commands of the interface: Constant definitions *)
 
-let rec under_binders env sigma f n c =
-  if Int.equal n 0 then f env sigma (EConstr.of_constr c) else
-    match Constr.kind 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 red_constant_entry n ce sigma = function
-  | None -> ce
+let red_constant_body red_opt env sigma body = match red_opt with
+  | None -> sigma, body
   | 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 (_, c) = redfun env sigma c in
-        EConstr.Unsafe.to_constr c
-      in
-      { ce with const_entry_body = Future.chain proof_out
-        (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
+    let red, _ = reduction_of_red_expr env red in
+    red env sigma body
 
 let warn_implicits_in_term =
   CWarnings.create ~name:"implicits-in-term" ~category:"implicits"
@@ -65,7 +45,7 @@ let interp_definition pl bl poly red_option c ctypopt =
   let open EConstr in
   let env = Global.env() in
   (* Explicitly bound universes and constraints *)
-  let evd, decl = Univdecls.interp_univ_decl_opt env pl in
+  let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in
   (* Build the parameters *)
   let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars env evd bl in
   (* Build the type *)
@@ -84,16 +64,18 @@ let interp_definition pl bl poly red_option c ctypopt =
       check_imps ~impsty ~impsbody;
       evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsty, Some ty
   in
+  (* Do the reduction *)
+  let evd, c = red_constant_body red_option env_bl evd c in
   (* universe minimization *)
   let evd = Evd.minimize_universes evd in
   (* Substitute evars and universes, and add parameters.
      Note: in program mode some evars may remain. *)
-  let ctx = List.map (EConstr.to_rel_decl evd) ctx in
-  let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr evd c) ctx in
-  let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr evd ty) ctx) tyopt in
+  let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in
+  let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in
+  let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in
   (* Keep only useful universes. *)
   let uvars_fold uvars c =
-    Univ.LSet.union uvars (universes_of_constr env evd (of_constr c))
+    Univ.LSet.union uvars (universes_of_constr evd (of_constr c))
   in
   let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in
   let evd = Evd.restrict_universe_context evd uvars in
@@ -101,10 +83,12 @@ let interp_definition pl bl poly red_option c ctypopt =
   let uctx = Evd.check_univ_decl ~poly evd decl in
   (* We're done! *)
   let ce = definition_entry ?types:tyopt ~univs:uctx c in
-  (red_constant_entry (Context.Rel.length ctx) ce evd red_option, evd, decl, imps)
+  (ce, evd, decl, imps)
 
 let check_definition (ce, evd, _, imps) =
-  check_evars_are_solved (Global.env ()) evd Evd.empty;
+  let env = Global.env () in
+  let empty_sigma = Evd.from_env env in
+  check_evars_are_solved env evd empty_sigma;
   ce
 
 let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook =
@@ -118,7 +102,7 @@ let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook =
       assert(Univ.ContextSet.is_empty ctx);
       let typ = match ce.const_entry_type with
         | Some t -> t
-        | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c))
+        | None -> EConstr.to_constr ~abort_on_undefined_evars:false evd (Retyping.get_type_of env evd (EConstr.of_constr c))
       in
       Obligations.check_evars env evd;
       let obls, _, c, cty =
diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli
index 6f81c457..7f1c902c 100644
--- a/vernac/comDefinition.mli
+++ b/vernac/comDefinition.mli
@@ -29,4 +29,4 @@ val do_definition : program_mode:bool ->
 val interp_definition :
   universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr ->
   constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map *
-                        Univdecls.universe_decl * Impargs.manual_implicits
+                        UState.universe_decl * Impargs.manual_implicits
diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml
index 1c141c01..37258c2d 100644
--- a/vernac/comFixpoint.ml
+++ b/vernac/comFixpoint.ml
@@ -13,7 +13,6 @@ open Decl_kinds
 open Pretyping
 open Evarutil
 open Evarconv
-open Misctypes
 
 module RelDecl = Context.Rel.Declaration
 
@@ -173,11 +172,12 @@ let interp_recursive ~program_mode ~cofix fixl notations =
         | None , acc -> acc
         | x , None -> x
         | Some ls , Some us ->
-           let lsu = ls.univdecl_instance and usu = us.univdecl_instance in
+          let open UState in
+          let lsu = ls.univdecl_instance and usu = us.univdecl_instance in
            if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then
              user_err Pp.(str "(co)-recursive definitions should all have the same universe binders");
            Some us) fixl None in
-  let sigma, decl = Univdecls.interp_univ_decl_opt env all_universes in
+  let sigma, decl = interp_univ_decl_opt env all_universes in
   let sigma, (fixctxs, fiximppairs, fixannots) =
     on_snd List.split3 @@
       List.fold_left_map (fun sigma -> interp_fix_context env sigma ~cofix) sigma fixl in
@@ -199,9 +199,7 @@ let interp_recursive ~program_mode ~cofix fixl notations =
              try
                let sigma, h_term = fix_proto sigma in
                let app = mkApp (h_term, [|sort; t|]) in
-               let _evd = ref sigma in
-               let res = Typing.e_solve_evars env _evd app in
-               !_evd, res
+               Typing.solve_evars env sigma app
              with e when CErrors.noncritical e -> sigma, t
            in
            sigma, LocalAssum (id,fixprot) :: env'
@@ -224,8 +222,9 @@ let interp_recursive ~program_mode ~cofix fixl notations =
 
   (* Instantiate evars and check all are resolved *)
   let sigma = solve_unif_constraints_with_heuristics env_rec sigma in
-  let sigma, _ = nf_evars_and_universes sigma in
-  let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr sigma) c) fixdefs in
+  let sigma = Evd.minimize_universes sigma in
+  (* XXX: We still have evars here in Program *)
+  let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr ~abort_on_undefined_evars:false sigma) c) fixdefs in
   let fixtypes = List.map EConstr.(to_constr sigma) fixtypes in
   let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in
 
@@ -233,7 +232,7 @@ let interp_recursive ~program_mode ~cofix fixl notations =
   (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots
 
 let check_recursive isfix env evd (fixnames,fixdefs,_) =
-  check_evars_are_solved env evd Evd.empty;
+  check_evars_are_solved env evd (Evd.from_env env);
   if List.for_all Option.has_some fixdefs then begin
     let fixdefs = List.map Option.get fixdefs in
     check_mutuality env evd isfix (List.combine fixnames fixdefs)
@@ -263,7 +262,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind
     let env = Global.env() in
     let indexes = search_guard env indexes fixdecls in
     let fiximps = List.map (fun (n,r,p) -> r) fiximps in
-    let vars = Univops.universes_of_constr env (mkFix ((indexes,0),fixdecls)) in
+    let vars = Univops.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
@@ -296,8 +295,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n
     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 env = Global.env () in
-    let vars = Univops.universes_of_constr env (List.hd fixdecls) in
+    let vars = Univops.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
diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli
index 36c2993a..b1a9c8a5 100644
--- a/vernac/comFixpoint.mli
+++ b/vernac/comFixpoint.mli
@@ -33,7 +33,7 @@ val do_cofixpoint :
 type structured_fixpoint_expr = {
   fix_name : Id.t;
   fix_univs : Constrexpr.universe_decl_expr option;
-  fix_annot : Misctypes.lident option;
+  fix_annot : lident option;
   fix_binders : local_binder_expr list;
   fix_body : constr_expr option;
   fix_type : constr_expr
@@ -49,7 +49,7 @@ val interp_recursive :
   structured_fixpoint_expr list -> decl_notation list ->
 
   (* env / signature / univs / evar_map *)
-  (Environ.env * EConstr.named_context * Univdecls.universe_decl * Evd.evar_map) *
+  (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) *
   (* names / defs / types *)
   (Id.t list * Constr.constr option list * Constr.types list) *
   (* ctx per mutual def / implicits / struct annotations *)
@@ -74,20 +74,20 @@ type recursive_preentry =
 val interp_fixpoint :
   cofix:bool ->
   structured_fixpoint_expr list -> decl_notation list ->
-  recursive_preentry * Univdecls.universe_decl * UState.t *
+  recursive_preentry * UState.universe_decl * UState.t *
   (EConstr.rel_context * Impargs.manual_implicits * int option) list
 
 (** Registering fixpoints and cofixpoints in the environment *)
 (** [Not used so far] *)
 val declare_fixpoint :
   locality -> polymorphic ->
-  recursive_preentry * Univdecls.universe_decl * UState.t *
-  (Context.Rel.t * Impargs.manual_implicits * int option) list ->
+  recursive_preentry * UState.universe_decl * UState.t *
+  (Constr.rel_context * Impargs.manual_implicits * int option) list ->
   Proof_global.lemma_possible_guards -> decl_notation list -> unit
 
 val declare_cofixpoint : locality -> polymorphic ->
-  recursive_preentry * Univdecls.universe_decl * UState.t *
-  (Context.Rel.t * Impargs.manual_implicits * int option) list ->
+  recursive_preentry * UState.universe_decl * UState.t *
+  (Constr.rel_context * Impargs.manual_implicits * int option) list ->
   decl_notation list -> unit
 
 (** Very private function, do not use *)
diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml
index 05c40dbd..ad1ffa35 100644
--- a/vernac/comInductive.ml
+++ b/vernac/comInductive.ml
@@ -27,9 +27,7 @@ open Impargs
 open Reductionops
 open Indtypes
 open Pretyping
-open Evarutil
 open Indschemes
-open Misctypes
 open Context.Rel.Declaration
 open Entries
 
@@ -46,8 +44,8 @@ let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function
         user_err ?loc
          (strbrk"Cannot infer the non constant arguments of the conclusion of "
           ++ Id.print cs ++ str ".");
-      let args = List.map (fun id -> CAst.(make ?loc @@ CRef(make ?loc @@ Ident id,None))) params in
-      CAppExpl ((None,CAst.make ?loc @@ Ident name,None),List.rev args)
+      let args = List.map (fun id -> CAst.(make ?loc @@ CRef(qualid_of_ident ?loc id,None))) params in
+      CAppExpl ((None,qualid_of_ident ?loc name,None),List.rev args)
   | c -> c
   )
 
@@ -128,7 +126,7 @@ let make_conclusion_flexible sigma ty poly =
   else sigma
 
 let is_impredicative env u =
-  u = Prop Null || (is_impredicative_set env && u = Prop Pos)
+  u = Prop || (is_impredicative_set env && u = Set)
 
 let interp_ind_arity env sigma ind =
   let c = intern_gen IsType env sigma ind.ind_arity in
@@ -148,7 +146,6 @@ let interp_cstrs env sigma impls mldata arity ind =
   let sigma, (ctyps'', cimpls) =
     on_snd List.split @@
     List.fold_left_map (fun sigma l ->
-        on_snd (on_fst EConstr.Unsafe.to_constr) @@
         interp_type_evars_impls env sigma ~impls l) sigma ctyps' in
   sigma, (cnames, ctyps'', cimpls)
 
@@ -159,7 +156,7 @@ let sign_level env evd sign =
       | LocalDef _ -> lev, push_rel d env
       | LocalAssum _ ->
         let s = destSort (Reduction.whd_all env
-                            (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d))))))
+                            (EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))
         in
         let u = univ_of_sort s in
           (Univ.sup u lev, push_rel d env))
@@ -178,10 +175,76 @@ let is_flexible_sort evd u =
   | Some l -> Evd.is_flexible_level evd l
   | None -> false
 
+(**********************************************************************)
+(* Tools for template polymorphic inductive types                         *)
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur only in the le constraints *)
+
+(*
+   Solve a system of universe constraint of the form
+
+   u_s11, ..., u_s1p1, w1 <= u1
+   ...
+   u_sn1, ..., u_snpn, wn <= un
+
+where
+
+  - the ui (1 <= i <= n) are universe variables,
+  - the sjk select subsets of the ui for each equations,
+  - the wi are arbitrary complex universes that do not mention the ui.
+*)
+
+let is_direct_sort_constraint s v = match s with
+  | Some u -> Univ.univ_level_mem u v
+  | None -> false
+
+let solve_constraints_system levels level_bounds =
+  let open Univ in
+  let levels =
+    Array.mapi (fun i o ->
+      match o with
+      | Some u ->
+        (match Universe.level u with
+        | Some u -> Some u
+        | _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None)
+      | None -> None)
+      levels in
+  let v = Array.copy level_bounds in
+  let nind = Array.length v in
+  let clos = Array.map (fun _ -> Int.Set.empty) levels in
+  (* First compute the transitive closure of the levels dependencies *)
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then
+        clos.(i) <- Int.Set.add j clos.(i);
+    done;
+  done;
+  let rec closure () =
+    let continue = ref false in
+      Array.iteri (fun i deps ->
+        let deps' =
+          Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps
+        in
+          if Int.Set.equal deps deps' then ()
+          else (clos.(i) <- deps'; continue := true))
+        clos;
+      if !continue then closure ()
+      else ()
+  in
+  closure ();
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if not (Int.equal i j) && Int.Set.mem j clos.(i) then
+        (v.(i) <- Universe.sup v.(i) level_bounds.(j));
+    done;
+  done;
+  v
+
 let inductive_levels env evd 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
+    if a = Prop then None
     else Some (univ_of_sort a)) destarities
   in
   let cstrs_levels, min_levels, sizes =
@@ -206,8 +269,8 @@ let inductive_levels env evd poly arities inds =
   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)
+  let levels' = solve_constraints_system (Array.of_list levels)
+    (Array.of_list cstrs_levels)
   in
   let evd, arities =
     CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len ->
@@ -234,14 +297,14 @@ let inductive_levels env evd poly arities inds =
            (** "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
+            Evd.set_leq_sort env evd Set 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
+              Evd.set_eq_sort env evd Prop du
             else evd
           else Evd.set_eq_sort env evd (Type cu) du
         in
@@ -263,14 +326,17 @@ let check_param = function
 | CLocalPattern {CAst.loc} ->
     Loc.raise ?loc (Stream.Error "pattern with quote not allowed here")
 
-let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
+let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly prv finite =
   check_all_names_different indl;
   List.iter check_param paramsl;
-  let env0 = Global.env() in
+  if not (List.is_empty uparamsl) && not (List.is_empty notations)
+  then user_err (str "Inductives with uniform parameters may not have attached notations.");
   let pl = (List.hd indl).ind_univs in
-  let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in
+  let sigma, decl = interp_univ_decl_opt env0 pl in
+  let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) =
+    interp_context_evars env0 sigma uparamsl in
   let sigma, (impls, ((env_params, ctx_params), userimpls)) =
-    interp_context_evars env0 sigma paramsl
+    interp_context_evars ~impl_env:uimpls env_uparams sigma paramsl
   in
   let indnames = List.map (fun ind -> ind.ind_name) indl in
 
@@ -282,15 +348,15 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
   let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in
 
   let fullarities = List.map (fun (c, _, _) -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in
-  let env_ar = push_types env0 indnames fullarities in
+  let env_ar = push_types env_uparams indnames fullarities in
   let env_ar_params = EConstr.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 sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in
-  let ntn_impls = compute_internalization_env env0 sigma (Inductive (params,true)) indnames fullarities indimpls in
+  let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in
+  let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in
   let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in
 
   let sigma, constructors =
@@ -301,23 +367,44 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
      List.fold_left3_map (fun sigma -> interp_cstrs env_ar_params sigma impls) sigma mldatas arities indl)
      () in
 
+  (* generalize over the uniform parameters *)
+  let nparams = Context.Rel.length ctx_params in
+  let nuparams = Context.Rel.length ctx_uparams in
+  let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in
+  let uparam_subst =
+    List.init (List.length indl) EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs))
+    @ List.init nuparams EConstr.(fun i -> mkRel (i + 1)) in
+  let generalize_constructor c = EConstr.Unsafe.to_constr (EConstr.Vars.substnl uparam_subst nparams c) in
+  let constructors = List.map (fun (cnames,ctypes,cimpls) ->
+                         (cnames,List.map generalize_constructor ctypes,cimpls))
+                       constructors
+  in
+  let ctx_params = ctx_params @ ctx_uparams in
+  let userimpls = useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) userimpls) in
+  let indimpls = List.map (fun iimpl -> useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) iimpl)) indimpls in
+  let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_uparams) fullarities in
+  let env_ar = push_types env0 indnames fullarities in
+  let env_ar_params = EConstr.push_rel_context ctx_params env_ar in
+
   (* Try further to solve evars, and instantiate them *)
-  let sigma = solve_remaining_evars all_and_fail_flags env_params sigma Evd.empty in
+  let sigma = solve_remaining_evars all_and_fail_flags env_params sigma (Evd.from_env env_params) in
   (* Compute renewed arities *)
-  let sigma, nf = nf_evars_and_universes sigma in
+  let sigma = Evd.minimize_universes sigma in
+  let nf = Evarutil.nf_evars_universes sigma in
   let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in
   let arities = List.map EConstr.(to_constr sigma) arities in
   let sigma = List.fold_left2 (fun sigma ty poly -> make_conclusion_flexible sigma ty poly) sigma arities aritypoly in
   let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in
-  let sigma, nf' = nf_evars_and_universes sigma 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 sigma = Evd.minimize_universes sigma in
+  let nf = Evarutil.nf_evars_universes sigma 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 = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in
   let uctx = Evd.check_univ_decl ~poly sigma decl in
-  List.iter (fun c -> check_evars env_params Evd.empty sigma (EConstr.of_constr c)) arities;
-  Context.Rel.iter (fun c -> check_evars env0 Evd.empty sigma (EConstr.of_constr c)) ctx_params;
+  List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr c)) arities;
+  Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params;
   List.iter (fun (_,ctyps,_) ->
-    List.iter (fun c -> check_evars env_ar_params Evd.empty sigma (EConstr.of_constr c)) ctyps)
+    List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps)
     constructors;
 
   (* Build the inductive entries *)
@@ -357,6 +444,9 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
       InferCumulativity.infer_inductive env_ar mind_ent
    else mind_ent), Evd.universe_binders sigma, impls
 
+let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
+  interp_mutual_inductive_gen (Global.env()) ([],paramsl,indl) notations cum poly prv finite
+
 (* Very syntactical equality *)
 let eq_local_binders bl1 bl2 =
   List.equal local_binder_eq bl1 bl2
@@ -378,7 +468,7 @@ let extract_params indl =
 let extract_inductive indl =
   List.map (fun (({CAst.v=indname},pl),_,ar,lc) -> {
     ind_name = indname; ind_univs = pl;
-    ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar;
+    ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.GType [])) ar;
     ind_lc = List.map (fun (_,({CAst.v=id},t)) -> (id,t)) lc
   }) indl
 
@@ -439,10 +529,15 @@ type one_inductive_impls =
   Impargs.manual_explicitation list (* for inds *)*
   Impargs.manual_explicitation list list (* for constrs *)
 
-let do_mutual_inductive indl cum poly prv finite =
-  let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in
+type uniform_inductive_flag =
+  | UniformParameters
+  | NonUniformParameters
+
+let do_mutual_inductive indl cum poly prv ~uniform finite =
+  let (params,indl),coes,ntns = extract_mutual_inductive_declaration_components indl in
   (* Interpret the types *)
-  let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in
+  let indl = match uniform with UniformParameters -> (params, [], indl) | NonUniformParameters -> ([], params, indl) in
+  let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) indl ntns cum 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 *)
diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli
index 83393572..4e30ed7d 100644
--- a/vernac/comInductive.mli
+++ b/vernac/comInductive.mli
@@ -19,9 +19,14 @@ open Decl_kinds
 
 (** Entry points for the vernacular commands Inductive and CoInductive *)
 
+type uniform_inductive_flag =
+  | UniformParameters
+  | NonUniformParameters
+
 val do_mutual_inductive :
   (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag ->
-  polymorphic -> private_flag -> Declarations.recursivity_kind -> unit
+  polymorphic -> private_flag -> uniform:uniform_inductive_flag ->
+  Declarations.recursivity_kind -> unit
 
 (************************************************************************)
 (** Internal API  *)
@@ -37,7 +42,7 @@ type one_inductive_impls =
   Impargs.manual_implicits list (** for constrs *)
 
 val declare_mutual_inductive_with_eliminations :
-  mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list ->
+  mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list ->
   MutInd.t
 
 (** Exported for Funind *)
@@ -64,4 +69,4 @@ val extract_mutual_inductive_declaration_components :
 val interp_mutual_inductive :
   structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag ->
   polymorphic -> private_flag -> Declarations.recursivity_kind ->
-  mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list
+  mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list
diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml
index b95741ca..ad21a6d9 100644
--- a/vernac/comProgramFixpoint.ml
+++ b/vernac/comProgramFixpoint.ml
@@ -44,7 +44,7 @@ let mkSubset sigma name typ prop =
 
 let sigT = Lazy.from_fun build_sigma_type
 
-let make_qref s = CAst.make @@ Qualid (qualid_of_string s)
+let make_qref s = qualid_of_string s
 let lt_ref = make_qref "Init.Peano.lt"
 
 let rec telescope sigma l =
@@ -91,7 +91,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
   let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in
   Coqlib.check_required_library ["Coq";"Program";"Wf"];
   let env = Global.env() in
-  let sigma, decl = Univdecls.interp_univ_decl_opt env pl in
+  let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in
   let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars env sigma bl in
   let len = List.length binders_rel in
   let top_env = push_rel_context binders_rel env in
@@ -187,12 +187,12 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
   let sigma, def =
     let sigma, h_a_term = Evarutil.new_global sigma (delayed_force fix_sub_ref) in
     let sigma, h_e_term = Evarutil.new_evar env sigma
-        ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof in
+        ~src:(Loc.tag @@ Evar_kinds.QuestionMark {
+            Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Evar_kinds.Define false;
+        }) wf_proof in
     sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |])
   in
-  let _evd = ref sigma in
-  let def = Typing.e_solve_evars env _evd def in
-  let sigma = !_evd in
+  let sigma, def = Typing.solve_evars env sigma def in
   let sigma = Evarutil.nf_evar_map sigma in
   let def = mkApp (def, [|intern_body_lam|]) in
   let binders_rel = nf_evar_context sigma binders_rel in
@@ -214,7 +214,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
         (** FIXME: include locality *)
         let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
         let gr = ConstRef c in
-        let () = Universes.register_universe_binders gr (Evd.universe_binders sigma) in
+        let () = UnivNames.register_universe_binders gr (Evd.universe_binders sigma) in
         if Impargs.is_implicit_args () || not (List.is_empty impls) then
           Impargs.declare_manual_implicits false gr [impls]
       in
@@ -229,7 +229,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
   in
   (* XXX: Capturing sigma here... bad bad *)
   let hook = Lemmas.mk_hook (hook sigma) in
-  let fullcoqc = EConstr.to_constr sigma def in
+  (* XXX: Grounding non-ground terms here... bad bad *)
+  let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in
   let fullctyp = EConstr.to_constr sigma typ in
   Obligations.check_evars env sigma;
   let evars, _, evars_def, evars_typ =
@@ -254,16 +255,17 @@ let do_program_recursive local poly fixkind fixl ntns =
     interp_recursive ~cofix ~program_mode:true fixl ntns
   in
     (* Program-specific code *)
-    (* Get the interesting evars, those that were not instanciated *)
+    (* Get the interesting evars, those that were not instantiated *)
   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 =
-      EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign)
+      EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign)
     and typ =
-      EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign)
+      (* Worrying... *)
+      EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign)
     in
     let evm = collect_evars_of_term evd def typ in
     let evars, _, def, typ =
diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli
index 010874e2..c5e704a5 100644
--- a/vernac/declareDef.mli
+++ b/vernac/declareDef.mli
@@ -8,17 +8,17 @@
 (*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Decl_kinds
 open Names
+open Decl_kinds
 
 val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool
 
 val declare_definition : Id.t -> definition_kind ->
-  Safe_typing.private_constants Entries.definition_entry -> Universes.universe_binders -> Impargs.manual_implicits ->
-    Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference
+  Safe_typing.private_constants Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits ->
+    GlobRef.t Lemmas.declaration_hook -> GlobRef.t
 
 val declare_fix : ?opaque:bool -> definition_kind ->
-  Universes.universe_binders -> Entries.constant_universes_entry ->
+  UnivNames.universe_binders -> Entries.constant_universes_entry ->
   Id.t -> Safe_typing.private_constants Entries.proof_output ->
   Constr.types -> Impargs.manual_implicits ->
-  Globnames.global_reference
+  GlobRef.t
diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml
new file mode 100644
index 00000000..16101396
--- /dev/null
+++ b/vernac/egramcoq.ml
@@ -0,0 +1,537 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Util
+open CErrors
+open Names
+open Libnames
+open Constrexpr
+open Extend
+open Notation_gram
+open Pcoq
+
+(**********************************************************************)
+(* This determines (depending on the associativity of the current
+   level and on the expected associativity) if a reference to constr_n is
+   a reference to the current level (to be translated into "SELF" on the
+   left border and into "constr LEVEL n" elsewhere), to the level below
+   (to be translated into "NEXT") or to an below wrt associativity (to be
+   translated in camlp5 into "constr" without level) or to another level
+   (to be translated into "constr LEVEL n")
+
+   The boolean is true if the entry was existing _and_ empty; this to
+   circumvent a weakness of camlp5 whose undo mechanism is not the
+   converse of the extension mechanism *)
+
+let constr_level = string_of_int
+
+let default_levels =
+  [200,Extend.RightA,false;
+   100,Extend.RightA,false;
+   99,Extend.RightA,true;
+   90,Extend.RightA,true;
+   10,Extend.LeftA,false;
+   9,Extend.RightA,false;
+   8,Extend.RightA,true;
+   1,Extend.LeftA,false;
+   0,Extend.RightA,false]
+
+let default_pattern_levels =
+  [200,Extend.RightA,true;
+   100,Extend.RightA,false;
+   99,Extend.RightA,true;
+   90,Extend.RightA,true;
+   10,Extend.LeftA,false;
+   1,Extend.LeftA,false;
+   0,Extend.RightA,false]
+
+let default_constr_levels = (default_levels, default_pattern_levels)
+
+let find_levels levels = function
+  | InConstrEntry -> levels, String.Map.find "constr" levels
+  | InCustomEntry s ->
+     try levels, String.Map.find s levels
+     with Not_found ->
+     String.Map.add s ([],[]) levels, ([],[])
+
+let save_levels levels custom lev =
+  let s = match custom with InConstrEntry -> "constr" | InCustomEntry s -> s in
+  String.Map.add s lev levels
+
+(* At a same level, LeftA takes precedence over RightA and NoneA *)
+(* In case, several associativity exists for a level, we make two levels, *)
+(* first LeftA, then RightA and NoneA together *)
+
+let admissible_assoc = function
+  | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false
+  | Extend.RightA, Some Extend.LeftA -> false
+  | _ -> true
+
+let create_assoc = function
+  | None -> Extend.RightA
+  | Some a -> a
+
+let error_level_assoc p current expected =
+  let open Pp in
+  let pr_assoc = function
+    | Extend.LeftA -> str "left"
+    | Extend.RightA -> str "right"
+    | Extend.NonA -> str "non" in
+  user_err 
+    (str "Level " ++ int p ++ str " is already declared " ++
+     pr_assoc current ++ str " associative while it is now expected to be " ++
+     pr_assoc expected ++ str " associative.")
+
+let create_pos = function
+  | None -> Extend.First
+  | Some lev -> Extend.After (constr_level lev)
+
+let find_position_gen current ensure assoc lev =
+  match lev with
+  | None ->
+      current, (None, None, None, None)
+  | Some n ->
+      let after = ref None in
+      let init = ref None in
+      let rec add_level q = function
+        | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l
+        | (p,a,reinit)::l when Int.equal p n ->
+            if reinit then
+	      let a' = create_assoc assoc in
+              (init := Some (a',create_pos q); (p,a',false)::l)
+	    else if admissible_assoc (a,assoc) then
+	      raise Exit
+            else
+	      error_level_assoc p a (Option.get assoc)
+	| l -> after := q; (n,create_assoc assoc,ensure)::l
+      in
+      try
+	let updated = add_level None current in
+	let assoc = create_assoc assoc in
+        begin match !init with
+        | None ->
+	  (* Create the entry *)
+	   updated, (Some (create_pos !after), Some assoc, Some (constr_level n), None)
+        | _ ->
+	  (* The reinit flag has been updated *)
+	   updated, (Some (Extend.Level (constr_level n)), None, None, !init)
+        end
+      with
+	  (* Nothing has changed *)
+          Exit ->
+	    (* Just inherit the existing associativity and name (None) *)
+	    current, (Some (Extend.Level (constr_level n)), None, None, None)
+
+let rec list_mem_assoc_triple x = function
+  | [] -> false
+  | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l
+
+let register_empty_levels accu forpat levels =
+  let rec filter accu = function
+  | [] -> ([], accu)
+  | (where,n) :: rem ->
+    let rem, accu = filter accu rem in
+    let accu, (clev, plev) = find_levels accu where in
+    let levels = if forpat then plev else clev in
+    if not (list_mem_assoc_triple n levels) then
+      let nlev, ans = find_position_gen levels true None (Some n) in
+      let nlev = if forpat then (clev, nlev) else (nlev, plev) in
+      (where, ans) :: rem, save_levels accu where nlev
+    else rem, accu
+  in
+  filter accu levels
+
+let find_position accu custom forpat assoc level =
+  let accu, (clev, plev) = find_levels accu custom in
+  let levels = if forpat then plev else clev in
+  let nlev, ans = find_position_gen levels false assoc level in
+  let nlev = if forpat then (clev, nlev) else (nlev, plev) in
+  (ans, save_levels accu custom nlev)
+
+(**************************************************************************)
+(*
+ * --- Note on the mapping of grammar productions to camlp5 actions ---
+ *
+ * Translation of environments: a production
+ *   [ nt1(x1) ... nti(xi) ] -> act(x1..xi)
+ * is written (with camlp5 conventions):
+ *   (fun vi -> .... (fun v1 -> act(v1 .. vi) )..)
+ * where v1..vi are the values generated by non-terminals nt1..nti.
+ * Since the actions are executed by substituting an environment,
+ * the make_*_action family build the following closure:
+ *
+ *      ((fun env ->
+ *          (fun vi ->
+ *             (fun env -> ...
+ *
+ *                  (fun v1 ->
+ *                     (fun env -> gram_action .. env act)
+ *                     ((x1,v1)::env))
+ *                  ...)
+ *             ((xi,vi)::env)))
+ *         [])
+ *)
+
+(**********************************************************************)
+(** Declare Notations grammar rules                                   *)
+
+(**********************************************************************)
+(* Binding constr entry keys to entries                               *)
+
+(* Camlp5 levels do not treat NonA: use RightA with a NEXT on the left *)
+let camlp5_assoc = function
+  | Some NonA | Some RightA -> RightA
+  | None | Some LeftA -> LeftA
+
+let assoc_eq al ar = match al, ar with
+| NonA, NonA
+| RightA, RightA
+| LeftA, LeftA -> true
+| _, _ -> false
+
+(* [adjust_level assoc from prod] where [assoc] and [from] are the name
+   and associativity of the level where to add the rule; the meaning of
+   the result is
+
+     None = SELF
+     Some None = NEXT
+     Some (Some (n,cur)) = constr LEVEL n
+         s.t. if [cur] is set then [n] is the same as the [from] level *)
+let adjust_level assoc from = function
+(* Associativity is None means force the level *)
+  | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true))
+(* Compute production name on the right side *)
+  (* If NonA or LeftA on the right-hand side, set to NEXT *)
+  | (NumLevel n,BorderProd (Right,Some (NonA|LeftA))) ->
+      Some None
+  (* If RightA on the right-hand side, set to the explicit (current) level *)
+  | (NumLevel n,BorderProd (Right,Some RightA)) ->
+      Some (Some (n,true))
+(* Compute production name on the left side *)
+  (* If NonA on the left-hand side, adopt the current assoc ?? *)
+  | (NumLevel n,BorderProd (Left,Some NonA)) -> None
+  (* If the expected assoc is the current one, set to SELF *)
+  | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp5_assoc assoc) ->
+      None
+  (* Otherwise, force the level, n or n-1, according to expected assoc *)
+  | (NumLevel n,BorderProd (Left,Some a)) ->
+    begin match a with
+    | LeftA -> Some (Some (n, true))
+    | _ -> Some None
+    end
+  (* None means NEXT *)
+  | (NextLevel,_) -> Some None
+(* Compute production name elsewhere *)
+  | (NumLevel n,InternalProd) ->
+    if from = n + 1 then Some None else Some (Some (n, Int.equal n from))
+
+type _ target =
+| ForConstr : constr_expr target
+| ForPattern : cases_pattern_expr target
+
+type prod_info = production_level * production_position
+
+type (_, _) entry =
+| TTName : ('self, lname) entry
+| TTReference : ('self, qualid) entry
+| TTBigint : ('self, Constrexpr.raw_natural_number) entry
+| TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry
+| TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry
+| TTPattern : int -> ('self, cases_pattern_expr) entry
+| TTOpenBinderList : ('self, local_binder_expr list) entry
+| TTClosedBinderList : Tok.t list -> ('self, local_binder_expr list list) entry
+
+type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry
+
+let constr_custom_entry : (string, Constrexpr.constr_expr) entry_command =
+  create_entry_command "constr" (fun s st -> [s], st)
+let pattern_custom_entry : (string, Constrexpr.cases_pattern_expr) entry_command =
+  create_entry_command "pattern" (fun s st -> [s], st)
+
+let custom_entry_locality = Summary.ref ~name:"LOCAL-CUSTOM-ENTRY" String.Set.empty
+(** If the entry is present then local *)
+
+let create_custom_entry ~local s =
+  if List.mem s ["constr";"pattern";"ident";"global";"binder";"bigint"] then
+    user_err Pp.(quote (str s) ++ str " is a reserved entry name.");
+  let sc = "constr:"^s in
+  let sp = "pattern:"^s in
+  let _ = extend_entry_command constr_custom_entry sc in
+  let _ = extend_entry_command pattern_custom_entry sp in
+  let () = if local then custom_entry_locality := String.Set.add s !custom_entry_locality in
+  ()
+
+let find_custom_entry s =
+  let sc = "constr:"^s in
+  let sp = "pattern:"^s in
+  try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp)
+  with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".")
+
+let locality_of_custom_entry s = String.Set.mem s !custom_entry_locality
+
+(* This computes the name of the level where to add a new rule *)
+let interp_constr_entry_key : type r. _ -> r target -> int -> r Entry.t * int option =
+  fun custom forpat level ->
+  match custom with
+  | InCustomEntry s ->
+     (let (entry_for_constr, entry_for_patttern) = find_custom_entry s in
+     match forpat with
+     | ForConstr -> entry_for_constr, Some level
+     | ForPattern -> entry_for_patttern, Some level)
+  | InConstrEntry ->
+  match forpat with
+  | ForConstr ->
+    if level = 200 then Constr.binder_constr, None
+    else Constr.operconstr, Some level
+  | ForPattern -> Constr.pattern, Some level
+
+let target_entry : type s. notation_entry -> s target -> s Entry.t = function
+| InConstrEntry ->
+   (function
+   | ForConstr -> Constr.operconstr
+   | ForPattern -> Constr.pattern)
+| InCustomEntry s ->
+   let (entry_for_constr, entry_for_patttern) = find_custom_entry s in
+   function
+   | ForConstr -> entry_for_constr
+   | ForPattern -> entry_for_patttern
+
+let is_self from e = match e with
+| (NumLevel n, BorderProd (Right, _ (* Some(NonA|LeftA) *))) -> false
+| (NumLevel n, BorderProd (Left, _)) -> Int.equal from n
+| _ -> false
+
+let is_binder_level from e = match e with
+| (NumLevel 200, (BorderProd (Right, _) | InternalProd)) -> from = 200
+| _ -> false
+
+let make_sep_rules = function
+  | [tk] -> Atoken tk
+  | tkl ->
+  let rec mkrule : Tok.t list -> string rules = function
+  | [] -> Rules ({ norec_rule = Stop }, fun _ -> (* dropped anyway: *) "")
+  | tkn :: rem ->
+    let Rules ({ norec_rule = r }, f) = mkrule rem in
+    let r = { norec_rule = Next (r, Atoken tkn) } in
+    Rules (r, fun _ -> f)
+  in
+  let r = mkrule (List.rev tkl) in
+  Arules [r]
+
+let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) symbol = fun custom p assoc from forpat ->
+  if custom = InConstrEntry && is_binder_level from p then Aentryl (target_entry InConstrEntry forpat, "200")
+  else if is_self from p then Aself
+  else
+    let g = target_entry custom forpat in
+    let lev = adjust_level assoc from p in
+    begin match lev with
+    | None -> Aentry g
+    | Some None -> Anext
+    | Some (Some (lev, cur)) -> Aentryl (g, string_of_int lev)
+    end
+
+let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun assoc from typ -> match typ with
+| TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat
+| TTConstrList (typ', [], forpat) ->
+  Alist1 (symbol_of_target InConstrEntry typ' assoc from forpat)
+| TTConstrList (typ', tkl, forpat) ->
+  Alist1sep (symbol_of_target InConstrEntry typ' assoc from forpat, make_sep_rules tkl)
+| TTPattern p -> Aentryl (Constr.pattern, string_of_int p)
+| TTClosedBinderList [] -> Alist1 (Aentry Constr.binder)
+| TTClosedBinderList tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl)
+| TTName -> Aentry Prim.name
+| TTOpenBinderList -> Aentry Constr.open_binders
+| TTBigint -> Aentry Prim.bigint
+| TTReference -> Aentry Constr.global
+
+let interp_entry forpat e = match e with
+| ETProdName -> TTAny TTName
+| ETProdReference -> TTAny TTReference
+| ETProdBigint -> TTAny TTBigint
+| ETProdConstr (s,p) -> TTAny (TTConstr (s, p, forpat))
+| ETProdPattern p -> TTAny (TTPattern p)
+| ETProdConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat))
+| ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList
+| ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl)
+
+let cases_pattern_expr_of_name { CAst.loc; v = na } = CAst.make ?loc @@ match na with
+  | Anonymous -> CPatAtom None
+  | Name id   -> CPatAtom (Some (qualid_of_ident ?loc id))
+
+type 'r env = {
+  constrs : 'r list;
+  constrlists : 'r list list;
+  binders : cases_pattern_expr list;
+  binderlists : local_binder_expr list list;
+}
+
+let push_constr subst v = { subst with constrs = v :: subst.constrs }
+
+let push_item : type s r. s target -> (s, r) entry -> s env -> r -> s env = fun forpat e subst v ->
+match e with
+| TTConstr _ -> push_constr subst v
+| TTName ->
+  begin match forpat with
+  | ForConstr -> { subst with binders = cases_pattern_expr_of_name v :: subst.binders }
+  | ForPattern -> push_constr subst (cases_pattern_expr_of_name v)
+  end
+| TTPattern _ ->
+  begin match forpat with
+  | ForConstr -> { subst with binders = v :: subst.binders }
+  | ForPattern -> push_constr subst v
+  end
+| TTOpenBinderList -> { subst with binderlists = v :: subst.binderlists }
+| TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists }
+| TTBigint ->
+  begin match forpat with
+  | ForConstr ->  push_constr subst (CAst.make @@ CPrim (Numeral (v,true)))
+  | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (v,true)))
+  end
+| TTReference ->
+  begin match forpat with
+  | ForConstr  -> push_constr subst (CAst.make @@ CRef (v, None))
+  | ForPattern -> push_constr subst (CAst.make @@ CPatAtom (Some v))
+  end
+| TTConstrList _ -> { subst with constrlists = v :: subst.constrlists }
+
+type (_, _) ty_symbol =
+| TyTerm : Tok.t -> ('s, string) ty_symbol
+| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) symbol * bool -> ('s, 'a) ty_symbol
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule
+| TyMark : int * bool * int * ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule
+
+type 'r gen_eval = Loc.t -> 'r env -> 'r
+
+let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> a = function
+| TyStop ->
+  fun f env loc -> f loc env
+| TyNext (rem, TyTerm _) ->
+  fun f env _ -> ty_eval rem f env
+| TyNext (rem, TyNonTerm (_, _, _, false)) ->
+  fun f env _ -> ty_eval rem f env
+| TyNext (rem, TyNonTerm (forpat, e, _, true)) ->
+  fun f env v ->
+    ty_eval rem f (push_item forpat e env v)
+| TyMark (n, b, p, rem) ->
+  fun f env ->
+    let heads, constrs = List.chop n env.constrs in
+    let constrlists, constrs =
+      if b then
+         (* We rearrange constrs = c1..cn rem and constrlists = [d1..dr e1..ep] rem' into
+            constrs = e1..ep rem and constrlists [c1..cn d1..dr] rem' *)
+         let constrlist = List.hd env.constrlists in
+         let constrlist, tail = List.chop (List.length constrlist - p) constrlist in
+         (heads @ constrlist) :: List.tl env.constrlists, tail @ constrs
+      else
+         (* We rearrange constrs = c1..cn e1..ep rem into
+            constrs = e1..ep rem and add a constr list [c1..cn] *)
+        let constrlist, tail = List.chop (n - p) heads in
+        constrlist :: env.constrlists, tail @ constrs
+    in
+    ty_eval rem f { env with constrs; constrlists; } 
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Stop
+| TyMark (_, _, _, r) -> ty_erase r
+| TyNext (rem, TyTerm tok) -> Next (ty_erase rem, Atoken tok)
+| TyNext (rem, TyNonTerm (_, _, s, _)) -> Next (ty_erase rem, s)
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let make_ty_rule assoc from forpat prods =
+  let rec make_ty_rule = function
+  | [] -> AnyTyRule TyStop
+  | GramConstrTerminal tok :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    AnyTyRule (TyNext (r, TyTerm tok))
+  | GramConstrNonTerminal (e, var) :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    let TTAny e = interp_entry forpat e in
+    let s = symbol_of_entry assoc from e in
+    let bind = match var with None -> false | Some _ -> true in
+    AnyTyRule (TyNext (r, TyNonTerm (forpat, e, s, bind)))
+  | GramConstrListMark (n, b, p) :: rem ->
+    let AnyTyRule r = make_ty_rule rem in
+    AnyTyRule (TyMark (n, b, p, r))
+  in
+  make_ty_rule (List.rev prods)
+
+let target_to_bool : type r. r target -> bool = function
+| ForConstr -> false
+| ForPattern -> true
+
+let prepare_empty_levels forpat (where,(pos,p4assoc,name,reinit)) =
+  let empty = (pos, [(name, p4assoc, [])]) in
+  ExtendRule (target_entry where forpat, reinit, empty)
+
+let rec pure_sublevels' custom assoc from forpat level = function
+| [] -> []
+| GramConstrNonTerminal (e,_) :: rem ->
+   let rem = pure_sublevels' custom assoc from forpat level rem in
+   let push where p rem =
+     match symbol_of_target custom p assoc from forpat with
+     | Aentryl (_,i) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem
+     | _ -> rem in
+   (match e with
+   | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem
+   | ETProdConstr (s,p) -> push s p rem
+   | _ -> rem)
+| (GramConstrTerminal _ | GramConstrListMark _) :: rem -> pure_sublevels' custom assoc from forpat level rem
+
+let make_act : type r. r target -> _ -> r gen_eval = function
+| ForConstr -> fun notation loc env ->
+  let env = (env.constrs, env.constrlists, env.binders, env.binderlists) in
+  CAst.make ~loc @@ CNotation (notation, env)
+| ForPattern -> fun notation loc env ->
+  let env = (env.constrs, env.constrlists) in
+  CAst.make ~loc @@ CPatNotation (notation, env, [])
+
+let extend_constr state forpat ng =
+  let custom,n,_,_ = ng.notgram_level in
+  let assoc = ng.notgram_assoc in
+  let (entry, level) = interp_constr_entry_key custom forpat n in
+  let fold (accu, state) pt =
+    let AnyTyRule r = make_ty_rule assoc n forpat pt in
+    let symbs = ty_erase r in
+    let pure_sublevels = pure_sublevels' custom assoc n forpat level pt in
+    let isforpat = target_to_bool forpat in
+    let needed_levels, state = register_empty_levels state isforpat pure_sublevels in
+    let (pos,p4assoc,name,reinit), state = find_position state custom isforpat assoc level in
+    let empty_rules = List.map (prepare_empty_levels forpat) needed_levels in
+    let empty = { constrs = []; constrlists = []; binders = []; binderlists = [] } in
+    let act = ty_eval r (make_act forpat ng.notgram_notation) empty in
+    let rule = (name, p4assoc, [Rule (symbs, act)]) in
+    let r = ExtendRule (entry, reinit, (pos, [rule])) in
+    (accu @ empty_rules @ [r], state)
+  in
+  List.fold_left fold ([], state) ng.notgram_prods
+
+let constr_levels = GramState.field ()
+
+let extend_constr_notation ng state =
+  let levels = match GramState.get state constr_levels with
+  | None -> String.Map.add "constr" default_constr_levels String.Map.empty
+  | Some lev -> lev
+  in
+  (* Add the notation in constr *)
+  let (r, levels) = extend_constr levels ForConstr ng in
+  (* Add the notation in cases_pattern *)
+  let (r', levels) = extend_constr levels ForPattern ng in
+  let state = GramState.set state constr_levels levels in
+  (r @ r', state)
+
+let constr_grammar : one_notation_grammar grammar_command =
+  create_grammar_command "Notation" extend_constr_notation
+
+let extend_constr_grammar ntn = extend_grammar_command constr_grammar ntn
diff --git a/vernac/egramcoq.mli b/vernac/egramcoq.mli
new file mode 100644
index 00000000..3a6f8ae0
--- /dev/null
+++ b/vernac/egramcoq.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+(** Mapping of grammar productions to camlp5 actions *)
+
+(** This is the part specific to Coq-level Notation and Tactic Notation.
+    For the ML-level tactic and vernac extensions, see Egramml. *)
+
+(** {5 Adding notations} *)
+
+val extend_constr_grammar : Notation_gram.one_notation_grammar -> unit
+(** Add a term notation rule to the parsing system. *)
+
+val create_custom_entry : local:bool -> string -> unit
+val locality_of_custom_entry : string -> bool
diff --git a/vernac/egramml.ml b/vernac/egramml.ml
new file mode 100644
index 00000000..c5dedc88
--- /dev/null
+++ b/vernac/egramml.ml
@@ -0,0 +1,93 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Util
+open Extend
+open Pcoq
+open Genarg
+open Vernacexpr
+
+(** Grammar extensions declared at ML level *)
+
+type 's grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal :
+      ('a raw_abstract_argument_type option * ('s, 'a) symbol) Loc.located -> 's grammar_prod_item
+
+type 'a ty_arg = ('a -> raw_generic_argument)
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option ->
+  ('self, 'b -> 'a, 'r) ty_rule
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let rec ty_rule_of_gram = function
+| [] -> AnyTyRule TyStop
+| GramTerminal s :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let tok = Atoken (CLexer.terminal s) in
+  let r = TyNext (rem, tok, None) in
+  AnyTyRule r
+| GramNonTerminal (_, (t, tok)) :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let inj = Option.map (fun t obj -> Genarg.in_gen t obj) t in
+  let r = TyNext (rem, tok, inj) in
+  AnyTyRule r
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Extend.Stop
+| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok)
+
+type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r
+
+let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function
+| TyStop -> fun f loc -> f loc []
+| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f
+| TyNext (rem, tok, Some inj) -> fun f x ->
+  let f loc args = f loc (inj x :: args) in
+  ty_eval rem f
+
+let make_rule f prod =
+  let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in
+  let symb = ty_erase ty_rule in
+  let f loc l = f loc (List.rev l) in
+  let act = ty_eval ty_rule f in
+  Extend.Rule (symb, act)
+
+let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function
+| TUentry a -> ExtraArg a
+| TUentryl (a,l) -> ExtraArg a
+| TUopt(o) -> OptArg (proj_symbol o)
+| TUlist1 l -> ListArg (proj_symbol l)
+| TUlist1sep (l,_) -> ListArg (proj_symbol l)
+| TUlist0 l -> ListArg (proj_symbol l)
+| TUlist0sep (l,_) -> ListArg (proj_symbol l)
+
+(** Vernac grammar extensions *)
+
+let vernac_exts = ref []
+
+let get_extend_vernac_rule (s, i) =
+  try
+    let find ((name, j), _) = String.equal name s && Int.equal i j in
+    let (_, rules) = List.find find !vernac_exts in
+    rules
+  with
+  | Failure _ -> raise Not_found
+
+let extend_vernac_command_grammar s nt gl =
+  let nt = Option.default Pvernac.Vernac_.command nt in
+  vernac_exts := (s,gl) :: !vernac_exts;
+  let mkact loc l = VernacExtend (s, l) in
+  let rules = [make_rule mkact gl] in
+  grammar_extend nt None (None, [None, None, rules])
diff --git a/vernac/egramml.mli b/vernac/egramml.mli
new file mode 100644
index 00000000..c4f4fcfa
--- /dev/null
+++ b/vernac/egramml.mli
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Vernacexpr
+
+(** Mapping of grammar productions to camlp5 actions. *)
+
+(** This is the part specific to vernac extensions.
+    For the Coq-level Notation and Tactic Notation, see Egramcoq. *)
+
+type 's grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option *
+      ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item
+
+val extend_vernac_command_grammar :
+  Vernacexpr.extend_name -> vernac_expr Pcoq.Entry.t option ->
+    vernac_expr grammar_prod_item list -> unit
+
+val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list
+
+val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type
+
+(** Utility function reused in Egramcoq : *)
+
+val make_rule :
+  (Loc.t -> Genarg.raw_generic_argument list -> 'a) ->
+  'a grammar_prod_item list -> 'a Extend.production_rule
diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml
index f9167f96..7cf4e648 100644
--- a/vernac/explainErr.ml
+++ b/vernac/explainErr.ml
@@ -55,7 +55,7 @@ let process_vernac_interp_error exn = match fst exn with
     let msg =
       if !Constrextern.print_universes then
 	str "." ++ spc() ++ 
-	  Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
+          Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes i
       else
 	mt() in
     wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".")
@@ -64,8 +64,12 @@ let process_vernac_interp_error exn = match fst exn with
       wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te)
   | PretypeError(ctx,sigma,te) ->
       wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te)
+  | Notation.NumeralNotationError(ctx,sigma,te) ->
+      wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te)
   | Typeclasses_errors.TypeClassError(env, te) ->
       wrap_vernac_error exn (Himsg.explain_typeclass_error env te)
+  | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) ->
+    wrap_vernac_error exn (Himsg.explain_mismatched_contexts e c l x)
   | InductiveError e ->
       wrap_vernac_error exn (Himsg.explain_inductive_error e)
   | Modops.ModuleTypingError e ->
diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg
new file mode 100644
index 00000000..ecc7d3ff
--- /dev/null
+++ b/vernac/g_proofs.mlg
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+{
+
+open Glob_term
+open Constrexpr
+open Vernacexpr
+open Hints
+open Proof_global
+
+open Pcoq
+open Pcoq.Prim
+open Pcoq.Constr
+open Pvernac.Vernac_
+
+let thm_token = G_vernac.thm_token
+
+let hint = Entry.create "hint"
+
+let warn_deprecated_focus =
+  CWarnings.create ~name:"deprecated-focus" ~category:"deprecated"
+         (fun () ->
+           Pp.strbrk
+             "The Focus command is deprecated; use bullets or focusing brackets instead"
+         )
+
+let warn_deprecated_focus_n n =
+  CWarnings.create ~name:"deprecated-focus" ~category:"deprecated"
+         (fun () ->
+           Pp.(str "The Focus command is deprecated;" ++ spc ()
+               ++ str "use '" ++ int n ++ str ": {' instead")
+         )
+
+let warn_deprecated_unfocus =
+  CWarnings.create ~name:"deprecated-unfocus" ~category:"deprecated"
+         (fun () -> Pp.strbrk "The Unfocus command is deprecated")
+
+}
+
+(* Proof commands *)
+GRAMMAR EXTEND Gram
+  GLOBAL: hint command;
+
+  opt_hintbases:
+  [ [ -> { [] }
+    | ":"; l = LIST1 [id = IDENT -> { id } ] -> { l } ] ]
+  ;
+  command:
+    [ [ IDENT "Goal"; c = lconstr ->
+        { VernacDefinition (Decl_kinds.(NoDischarge, Definition), ((CAst.make ~loc Names.Anonymous), None), ProveBody ([], c)) }
+      | IDENT "Proof" -> { VernacProof (None,None) }
+      | IDENT "Proof" ; IDENT "Mode" ; mn = string -> { VernacProofMode mn }
+      | IDENT "Proof"; c = lconstr -> { VernacExactProof c }
+      | IDENT "Abort" -> { VernacAbort None }
+      | IDENT "Abort"; IDENT "All" -> { VernacAbortAll }
+      | IDENT "Abort"; id = identref -> { VernacAbort (Some id) }
+      | IDENT "Existential"; n = natural; c = constr_body ->
+	  { VernacSolveExistential (n,c) }
+      | IDENT "Admitted" -> { VernacEndProof Admitted }
+      | IDENT "Qed" -> { VernacEndProof (Proved (Opaque,None)) }
+      | IDENT "Save"; id = identref ->
+	  { VernacEndProof (Proved (Opaque, Some id)) }
+      | IDENT "Defined" -> { VernacEndProof (Proved (Transparent,None)) }
+      |	IDENT "Defined"; id=identref ->
+	  { VernacEndProof (Proved (Transparent,Some id)) }
+      | IDENT "Restart" -> { VernacRestart }
+      | IDENT "Undo" -> { VernacUndo 1 }
+      | IDENT "Undo"; n = natural -> { VernacUndo n }
+      | IDENT "Undo"; IDENT "To"; n = natural -> { VernacUndoTo n }
+      | IDENT "Focus" ->
+         { warn_deprecated_focus ~loc ();
+         VernacFocus None }
+      | IDENT "Focus"; n = natural ->
+         { warn_deprecated_focus_n n ~loc ();
+         VernacFocus (Some n) }
+      | IDENT "Unfocus" ->
+         { warn_deprecated_unfocus ~loc ();
+         VernacUnfocus }
+      | IDENT "Unfocused" -> { VernacUnfocused }
+      | IDENT "Show" -> { VernacShow (ShowGoal OpenSubgoals) }
+      | IDENT "Show"; n = natural -> { VernacShow (ShowGoal (NthGoal n)) }
+      | IDENT "Show"; id = ident -> { VernacShow (ShowGoal (GoalId id)) }
+      | IDENT "Show"; IDENT "Script" -> { VernacShow ShowScript }
+      | IDENT "Show"; IDENT "Existentials" -> { VernacShow ShowExistentials }
+      | IDENT "Show"; IDENT "Universes" -> { VernacShow ShowUniverses }
+      | IDENT "Show"; IDENT "Conjectures" -> { VernacShow ShowProofNames }
+      | IDENT "Show"; IDENT "Proof" -> { VernacShow ShowProof }
+      | IDENT "Show"; IDENT "Intro" -> { VernacShow (ShowIntros false) }
+      | IDENT "Show"; IDENT "Intros" -> { VernacShow (ShowIntros true) }
+      | IDENT "Show"; IDENT "Match"; id = reference -> { VernacShow (ShowMatch id) }
+      | IDENT "Guarded" -> { VernacCheckGuard }
+      (* Hints for Auto and EAuto *)
+      | IDENT "Create"; IDENT "HintDb" ;
+	  id = IDENT ; b = [ "discriminated" -> { true } | -> { false } ] ->
+	    { VernacCreateHintDb (id, b) }
+      | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases ->
+	  { VernacRemoveHints (dbnames, ids) }
+      | IDENT "Hint"; h = hint; dbnames = opt_hintbases ->
+          { VernacHints (dbnames, h) }
+      ] ];
+  reference_or_constr:
+   [ [ r = global -> { HintsReference r }
+     | c = constr -> { HintsConstr c } ] ]
+  ;
+  hint:
+    [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info ->
+          { HintsResolve (List.map (fun x -> (info, true, x)) lc) }
+      | IDENT "Resolve"; "->"; lc = LIST1 global; n = OPT natural ->
+          { HintsResolveIFF (true, lc, n) }
+      | IDENT "Resolve"; "<-"; lc = LIST1 global; n = OPT natural ->
+          { HintsResolveIFF (false, lc, n) }
+      | IDENT "Immediate"; lc = LIST1 reference_or_constr -> { HintsImmediate lc }
+      | IDENT "Variables"; IDENT "Transparent" -> { HintsTransparency (HintsVariables, true) }
+      | IDENT "Variables"; IDENT "Opaque" -> { HintsTransparency (HintsVariables, false) }
+      | IDENT "Constants"; IDENT "Transparent" -> { HintsTransparency (HintsConstants, true) }
+      | IDENT "Constants"; IDENT "Opaque" -> { HintsTransparency (HintsConstants, false) }
+      | IDENT "Transparent"; lc = LIST1 global -> { HintsTransparency (HintsReferences lc, true) }
+      | IDENT "Opaque"; lc = LIST1 global -> { HintsTransparency (HintsReferences lc, false) }
+      | IDENT "Mode"; l = global; m = mode -> { HintsMode (l, m) }
+      | IDENT "Unfold"; lqid = LIST1 global -> { HintsUnfold lqid }
+      | IDENT "Constructors"; lc = LIST1 global -> { HintsConstructors lc } ] ]
+    ;
+  constr_body:
+    [ [ ":="; c = lconstr -> { c }
+      | ":"; t = lconstr; ":="; c = lconstr -> { CAst.make ~loc @@ CCast(c,CastConv t) } ] ]
+  ;
+  mode:
+    [ [ l = LIST1 [ "+" -> { ModeInput }
+                  | "!" -> { ModeNoHeadEvar }
+                  | "-" -> { ModeOutput } ] -> { l } ] ]
+  ;
+END
diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg
new file mode 100644
index 00000000..ecd19c47
--- /dev/null
+++ b/vernac/g_vernac.mlg
@@ -0,0 +1,1208 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+{
+
+open Pp
+open CErrors
+open Util
+open Names
+open Glob_term
+open Vernacexpr
+open Constrexpr
+open Constrexpr_ops
+open Extend
+open Decl_kinds
+open Declaremods
+open Declarations
+open Namegen
+open Tok (* necessary for camlp5 *)
+
+open Pcoq
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Module
+open Pvernac.Vernac_
+
+let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
+let _ = List.iter CLexer.add_keyword vernac_kw
+
+(* Rem: do not join the different GEXTEND into one, it breaks native *)
+(* compilation on PowerPC and Sun architectures *)
+
+let query_command = Entry.create "vernac:query_command"
+
+let subprf = Entry.create "vernac:subprf"
+
+let class_rawexpr = Entry.create "vernac:class_rawexpr"
+let thm_token = Entry.create "vernac:thm_token"
+let def_body = Entry.create "vernac:def_body"
+let decl_notation = Entry.create "vernac:decl_notation"
+let record_field = Entry.create "vernac:record_field"
+let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion"
+let instance_name = Entry.create "vernac:instance_name"
+let section_subset_expr = Entry.create "vernac:section_subset_expr"
+
+let make_bullet s =
+  let open Proof_bullet in
+  let n = String.length s in
+  match s.[0] with
+  | '-' -> Dash n
+  | '+' -> Plus n
+  | '*' -> Star n
+  | _ -> assert false
+
+let parse_compat_version = let open Flags in function
+  | "8.9" -> Current
+  | "8.8" -> V8_8
+  | "8.7" -> V8_7
+  | ("8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s ->
+    CErrors.user_err ~hdr:"get_compat_version"
+      Pp.(str "Compatibility with version " ++ str s ++ str " not supported.")
+  | s ->
+    CErrors.user_err ~hdr:"get_compat_version"
+      Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".")
+
+}
+
+GRAMMAR EXTEND Gram
+  GLOBAL: vernac_control gallina_ext noedit_mode subprf;
+  vernac_control: FIRST
+    [ [ IDENT "Time"; c = located_vernac -> { VernacTime (false,c) }
+      | IDENT "Redirect"; s = ne_string; c = located_vernac -> { VernacRedirect (s, c) }
+      | IDENT "Timeout"; n = natural; v = vernac_control -> { VernacTimeout(n,v) }
+      | IDENT "Fail"; v = vernac_control -> { VernacFail v }
+      | v = decorated_vernac -> { let (f, v) = v in VernacExpr(f, v) } ]
+    ]
+  ;
+  decorated_vernac:
+    [ [ a = attributes ; fv = vernac -> { let (f, v) = fv in (List.append a f, v) }
+      | fv = vernac -> { fv } ]
+    ]
+  ;
+  attributes:
+    [ [ "#[" ; a = attribute_list ; "]" -> { a } ]
+    ]
+  ;
+  attribute_list:
+    [ [ a = LIST0 attribute SEP "," -> { a } ]
+    ]
+  ;
+  attribute:
+    [ [ k = ident ; v = attribute_value -> { Names.Id.to_string k, v } ]
+    ]
+  ;
+  attribute_value:
+    [ [ "=" ; v = string -> { VernacFlagLeaf v }
+      | "(" ; a = attribute_list ; ")" -> { VernacFlagList a }
+      | -> { VernacFlagEmpty } ]
+    ]
+  ;
+  vernac:
+    [ [ IDENT "Local"; v = vernac_poly -> { let (f, v) = v in (("local", VernacFlagEmpty) :: f, v) }
+      | IDENT "Global"; v = vernac_poly -> { let (f, v) = v in (("global", VernacFlagEmpty) :: f, v) }
+
+      | v = vernac_poly -> { v } ]
+    ]
+  ;
+  vernac_poly:
+    [ [ IDENT "Polymorphic"; v = vernac_aux -> { let (f, v) = v in (("polymorphic", VernacFlagEmpty) :: f, v) }
+      | IDENT "Monomorphic"; v = vernac_aux -> { let (f, v) = v in (("monomorphic", VernacFlagEmpty) :: f, v) }
+      | v = vernac_aux -> { v } ]
+    ]
+  ;
+  vernac_aux:
+    (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
+    (* "." is still in the stream and discard_to_dot works correctly         *)
+    [ [ IDENT "Program"; g = gallina; "." -> { (["program", VernacFlagEmpty], g) }
+      | IDENT "Program"; g = gallina_ext; "." -> { (["program", VernacFlagEmpty], g) }
+      | g = gallina; "." -> { ([], g) }
+      | g = gallina_ext; "." -> { ([], g) }
+      | c = command; "." -> { ([], c) }
+      | c = syntax; "." -> { ([], c) }
+      | c = subprf -> { ([], c) }
+    ] ]
+  ;
+  vernac_aux: LAST
+    [ [ prfcom = command_entry -> { ([], prfcom) } ] ]
+  ;
+  noedit_mode:
+    [ [ c = query_command -> { c None } ] ]
+  ;
+
+  subprf:
+  [ [ s = BULLET -> { VernacBullet (make_bullet s) }
+    | "{" -> { VernacSubproof None }
+    | "}" -> { VernacEndSubproof }
+    ] ]
+  ;
+
+  located_vernac:
+    [ [ v = vernac_control -> { CAst.make ~loc v } ] ]
+  ;
+END
+
+{
+
+let warn_plural_command =
+  CWarnings.create ~name:"plural-command" ~category:"pedantic" ~default:CWarnings.Disabled
+         (fun kwd -> strbrk (Printf.sprintf "Command \"%s\" expects more than one assumption." kwd))
+
+let test_plural_form loc kwd = function
+  | [(_,([_],_))] ->
+     warn_plural_command ~loc kwd
+  | _ -> ()
+
+let test_plural_form_types loc kwd = function
+  | [([_],_)] ->
+     warn_plural_command ~loc kwd
+  | _ -> ()
+
+let lname_of_lident : lident -> lname =
+  CAst.map (fun s -> Name s)
+
+let name_of_ident_decl : ident_decl -> name_decl =
+  on_fst lname_of_lident
+
+}
+
+(* Gallina declarations *)
+GRAMMAR EXTEND Gram
+  GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion
+    record_field decl_notation rec_definition ident_decl univ_decl;
+
+  gallina:
+      (* Definition, Theorem, Variable, Axiom, ... *)
+    [ [ thm = thm_token; id = ident_decl; bl = binders; ":"; c = lconstr;
+        l = LIST0
+          [ "with"; id = ident_decl; bl = binders; ":"; c = lconstr ->
+          { (id,(bl,c)) } ] ->
+          { VernacStartTheoremProof (thm, (id,(bl,c))::l) }
+      | stre = assumption_token; nl = inline; bl = assum_list ->
+	  { VernacAssumption (stre, nl, bl) }
+      | tk = assumptions_token; nl = inline; bl = assum_list ->
+          { let (kwd,stre) = tk in 
+            test_plural_form loc kwd bl;
+            VernacAssumption (stre, nl, bl) }
+      | d = def_token; id = ident_decl; b = def_body ->
+          { VernacDefinition (d, name_of_ident_decl id, b) }
+      | IDENT "Let"; id = identref; b = def_body ->
+          { VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) }
+      (* Gallina inductive declarations *)
+      | cum = OPT cumulativity_token; priv = private_token; f = finite_token;
+        indl = LIST1 inductive_definition SEP "with" ->
+	  { let (k,f) = f in
+          let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in
+          VernacInductive (cum, priv,f,indl) }
+      | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          { VernacFixpoint (NoDischarge, recs) }
+      | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          { VernacFixpoint (DoDischarge, recs) }
+      | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          { VernacCoFixpoint (NoDischarge, corecs) }
+      | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          { VernacCoFixpoint (DoDischarge, corecs) }
+      | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> { VernacScheme l }
+      | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from";
+	      l = LIST1 identref SEP "," -> { VernacCombinedScheme (id, l) }
+      | IDENT "Register"; IDENT "Inline"; id = identref ->
+          { VernacRegister(id, RegisterInline) }
+      | IDENT "Universe"; l = LIST1 identref -> { VernacUniverse l }
+      | IDENT "Universes"; l = LIST1 identref -> { VernacUniverse l }
+      | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> { VernacConstraint l }
+  ] ]
+  ;
+
+  thm_token:
+    [ [ "Theorem" -> { Theorem }
+      | IDENT "Lemma" -> { Lemma }
+      | IDENT "Fact" -> { Fact }
+      | IDENT "Remark" -> { Remark }
+      | IDENT "Corollary" -> { Corollary }
+      | IDENT "Proposition" -> { Proposition }
+      | IDENT "Property" -> { Property } ] ]
+  ;
+  def_token:
+    [ [ "Definition" -> { (NoDischarge,Definition) }
+      | IDENT "Example" -> { (NoDischarge,Example) }
+      | IDENT "SubClass" -> { (NoDischarge,SubClass) } ] ]
+  ;
+  assumption_token:
+    [ [ "Hypothesis" -> { (DoDischarge, Logical) }
+      | "Variable" -> { (DoDischarge, Definitional) }
+      | "Axiom" -> { (NoDischarge, Logical) }
+      | "Parameter" -> { (NoDischarge, Definitional) }
+      | IDENT "Conjecture" -> { (NoDischarge, Conjectural) } ] ]
+  ;
+  assumptions_token:
+    [ [ IDENT "Hypotheses" -> { ("Hypotheses", (DoDischarge, Logical)) }
+      | IDENT "Variables" -> { ("Variables", (DoDischarge, Definitional)) }
+      | IDENT "Axioms" -> { ("Axioms", (NoDischarge, Logical)) }
+      | IDENT "Parameters" -> { ("Parameters", (NoDischarge, Definitional)) }
+      | IDENT "Conjectures" -> { ("Conjectures", (NoDischarge, Conjectural)) } ] ]
+  ;
+  inline:
+    [ [ IDENT "Inline"; "("; i = INT; ")" -> { InlineAt (int_of_string i) }
+      | IDENT "Inline" -> { DefaultInline }
+      | -> { NoInline } ] ]
+  ;
+  univ_constraint:
+    [ [ l = universe_level; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ];
+	r = universe_level -> { (l, ord, r) } ] ]
+  ;
+  univ_decl :
+    [ [  "@{" ; l = LIST0 identref; ext = [ "+" -> { true } | -> { false } ];
+         cs = [ "|"; l' = LIST0 univ_constraint SEP ",";
+                ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) }
+              | ext = [ "}" -> { true } | "|}" -> { false } ] -> { ([], ext) } ]
+         ->
+         { let open UState in
+         { univdecl_instance = l;
+           univdecl_extensible_instance = ext;
+           univdecl_constraints = fst cs;
+           univdecl_extensible_constraints = snd cs } }
+    ] ]
+  ;
+  ident_decl:
+    [ [ i = identref; l = OPT univ_decl -> { (i, l) }
+  ] ]
+  ;
+  finite_token:
+    [ [ IDENT "Inductive" -> { (Inductive_kw,Finite) }
+      | IDENT "CoInductive" -> { (CoInductive,CoFinite) }
+      | IDENT "Variant" -> { (Variant,BiFinite) }
+      | IDENT "Record" -> { (Record,BiFinite) }
+      | IDENT "Structure" -> { (Structure,BiFinite) }
+      | IDENT "Class" -> { (Class true,BiFinite) } ] ]
+  ;
+  cumulativity_token:
+    [ [ IDENT "Cumulative" -> { VernacCumulative }
+      | IDENT "NonCumulative" -> { VernacNonCumulative } ] ]
+  ;
+  private_token:
+    [ [ IDENT "Private" -> { true } | -> { false } ] ]
+  ;
+  (* Simple definitions *)
+  def_body:
+    [ [ bl = binders; ":="; red = reduce; c = lconstr ->
+      { if List.exists (function CLocalPattern _ -> true | _ -> false) bl
+      then
+        (* FIXME: "red" will be applied to types in bl and Cast with remain *)
+        let c = mkCLambdaN ~loc bl c in
+	DefineBody ([], red, c, None)
+      else
+        (match c with
+        | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t)
+        | _ -> DefineBody (bl, red, c, None)) }
+    | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
+        { let ((bl, c), tyo) =
+          if List.exists (function CLocalPattern _ -> true | _ -> false) bl
+          then
+            (* FIXME: "red" will be applied to types in bl and Cast with remain *)
+            let c = CAst.make ~loc @@ CCast (c, CastConv t) in
+            (([],mkCLambdaN ~loc bl c), None)
+          else ((bl, c), Some t)
+        in
+	DefineBody (bl, red, c, tyo) }
+    | bl = binders; ":"; t = lconstr ->
+        { ProveBody (bl, t) } ] ]
+  ;
+  reduce:
+    [ [ IDENT "Eval"; r = red_expr; "in" -> { Some r }
+      | -> { None } ] ]
+  ;
+  one_decl_notation:
+    [ [ ntn = ne_lstring; ":="; c = constr;
+        scopt = OPT [ ":"; sc = IDENT -> { sc } ] -> { (ntn,c,scopt) } ] ]
+  ;
+  decl_sep:
+    [ [ IDENT "and" -> { () } ] ]
+  ;
+  decl_notation:
+    [ [ "where"; l = LIST1 one_decl_notation SEP decl_sep -> { l }
+    | -> { [] } ] ]
+  ;
+  (* Inductives and records *)
+  opt_constructors_or_fields:
+    [ [ ":="; lc = constructor_list_or_record_decl -> { lc }
+      | -> { RecordDecl (None, []) } ] ]
+  ;
+  inductive_definition:
+    [ [ oc = opt_coercion; id = ident_decl; indpar = binders;
+        c = OPT [ ":"; c = lconstr -> { c } ];
+        lc=opt_constructors_or_fields; ntn = decl_notation ->
+	   { (((oc,id),indpar,c,lc),ntn) } ] ]
+  ;
+  constructor_list_or_record_decl:
+    [ [ "|"; l = LIST1 constructor SEP "|" -> { Constructors l }
+      | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" ->
+	  { Constructors ((c id)::l) }
+      | id = identref ; c = constructor_type -> { Constructors [ c id ] }
+      | cstr = identref; "{"; fs = record_fields; "}" ->
+	  { RecordDecl (Some cstr,fs) }
+      | "{";fs = record_fields; "}" -> { RecordDecl (None,fs) }
+      |  -> { Constructors [] } ] ]
+  ;
+(*
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+*)
+  opt_coercion:
+    [ [ ">" -> { true }
+      |  -> { false } ] ]
+  ;
+  (* (co)-fixpoints *)
+  rec_definition:
+    [ [ id = ident_decl;
+	bl = binders_fixannot;
+        ty = type_cstr;
+	def = OPT [":="; def = lconstr -> { def } ]; ntn = decl_notation ->
+	  { let bl, annot = bl in ((id,annot,bl,ty,def),ntn) } ] ]
+  ;
+  corec_definition:
+    [ [ id = ident_decl; bl = binders; ty = type_cstr;
+        def = OPT [":="; def = lconstr -> { def }]; ntn = decl_notation ->
+          { ((id,bl,ty,def),ntn) } ] ]
+  ;
+  type_cstr:
+    [ [ ":"; c=lconstr -> { c }
+      | -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } ] ]
+  ;
+  (* Inductive schemes *)
+  scheme:
+    [ [ kind = scheme_kind -> { (None,kind) }
+      | id = identref; ":="; kind = scheme_kind -> { (Some id,kind) } ] ]
+  ;
+  scheme_kind:
+    [ [ IDENT "Induction"; "for"; ind = smart_global;
+          IDENT "Sort"; s = sort_family-> { InductionScheme(true,ind,s) }
+      | IDENT "Minimality"; "for"; ind = smart_global;
+          IDENT "Sort"; s = sort_family-> { InductionScheme(false,ind,s) }
+      | IDENT "Elimination"; "for"; ind = smart_global;
+          IDENT "Sort"; s = sort_family-> { CaseScheme(true,ind,s) }
+      | IDENT "Case"; "for"; ind = smart_global;
+          IDENT "Sort"; s = sort_family-> { CaseScheme(false,ind,s) }
+      | IDENT "Equality"; "for" ; ind = smart_global -> { EqualityScheme(ind) } ] ]
+  ;
+  (* Various Binders *)
+(*
+  (* ... without coercions *)
+  binder_nodef:
+    [ [ b = binder_let ->
+      (match b with
+          CLocalAssum(l,ty) -> (l,ty)
+        | CLocalDef _ ->
+            Util.user_err_loc
+              (loc,"fix_param",Pp.str"defined binder not allowed here.")) ] ]
+  ;
+*)
+  (* ... with coercions *)
+  record_field:
+  [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> { n } ];
+      ntn = decl_notation -> { (bd,pri),ntn } ] ]
+  ;
+  record_fields:
+    [ [ f = record_field; ";"; fs = record_fields -> { f :: fs }
+      | f = record_field; ";" -> { [f] }
+      | f = record_field -> { [f] }
+      | -> { [] }
+    ] ]
+  ;
+  record_binder_body:
+    [ [ l = binders; oc = of_type_with_opt_coercion;
+         t = lconstr -> { fun id -> (oc,AssumExpr (id,mkCProdN ~loc l t)) }
+      | l = binders; oc = of_type_with_opt_coercion;
+         t = lconstr; ":="; b = lconstr -> { fun id ->
+	   (oc,DefExpr (id,mkCLambdaN ~loc l b,Some (mkCProdN ~loc l t))) }
+      | l = binders; ":="; b = lconstr -> { fun id ->
+         match b.CAst.v with
+	 | CCast(b', (CastConv t|CastVM t|CastNative t)) ->
+	     (None,DefExpr(id,mkCLambdaN ~loc l b',Some (mkCProdN ~loc l t)))
+         | _ ->
+	     (None,DefExpr(id,mkCLambdaN ~loc l b,None)) } ] ]
+  ;
+  record_binder:
+    [ [ id = name -> { (None,AssumExpr(id, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) }
+      | id = name; f = record_binder_body -> { f id } ] ]
+  ;
+  assum_list:
+    [ [ bl = LIST1 assum_coe -> { bl } | b = simple_assum_coe -> { [b] } ] ]
+  ;
+  assum_coe:
+    [ [ "("; a = simple_assum_coe; ")" -> { a } ] ]
+  ;
+  simple_assum_coe:
+    [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr ->
+        { (not (Option.is_empty oc),(idl,c)) } ] ]
+  ;
+
+  constructor_type:
+    [[ l = binders;
+      t= [ coe = of_type_with_opt_coercion; c = lconstr ->
+	            { fun l id -> (not (Option.is_empty coe),(id,mkCProdN ~loc l c)) }
+            |  ->
+                 { fun l id -> (false,(id,mkCProdN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ]
+	 -> { t l }
+     ]]
+;
+
+  constructor:
+    [ [ id = identref; c=constructor_type -> { c id } ] ]
+  ;
+  of_type_with_opt_coercion:
+    [ [ ":>>" -> { Some false }
+	| ":>"; ">" -> { Some false }
+	| ":>" -> { Some true }
+	| ":"; ">"; ">" -> { Some false }
+	| ":"; ">" -> { Some true }
+	| ":" -> { None } ] ]
+  ;
+END
+
+{
+
+let only_starredidentrefs =
+  Gram.Entry.of_parser "test_only_starredidentrefs"
+    (fun strm ->
+      let rec aux n =
+      match Util.stream_nth n strm with
+        | KEYWORD "." -> ()
+        | KEYWORD ")" -> ()
+        | (IDENT _ | KEYWORD "Type" | KEYWORD "*") -> aux (n+1)
+        | _ -> raise Stream.Failure in
+      aux 0)
+let starredidentreflist_to_expr l =
+  match l with
+  | [] -> SsEmpty
+  | x :: xs -> List.fold_right (fun i acc -> SsUnion(i,acc)) xs x
+
+let warn_deprecated_include_type =
+  CWarnings.create ~name:"deprecated-include-type" ~category:"deprecated"
+         (fun () -> strbrk "Include Type is deprecated; use Include instead")
+
+}
+
+(* Modules and Sections *)
+GRAMMAR EXTEND Gram
+  GLOBAL: gallina_ext module_expr module_type section_subset_expr;
+
+  gallina_ext:
+    [ [ (* Interactive module declaration *)
+        IDENT "Module"; export = export_token; id = identref;
+	bl = LIST0 module_binder; sign = of_module_type;
+	body = is_module_expr ->
+	  { VernacDefineModule (export, id, bl, sign, body) }
+      | IDENT "Module"; "Type"; id = identref;
+	bl = LIST0 module_binder; sign = check_module_types;
+	body = is_module_type ->
+	  { VernacDeclareModuleType (id, bl, sign, body) }
+      | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref;
+	bl = LIST0 module_binder; ":"; mty = module_type_inl ->
+	  { VernacDeclareModule (export, id, bl, mty) }
+      (* Section beginning *)
+      | IDENT "Section"; id = identref -> { VernacBeginSection id }
+      | IDENT "Chapter"; id = identref -> { VernacBeginSection id }
+
+      (* This end a Section a Module or a Module Type *)
+      | IDENT "End"; id = identref -> { VernacEndSegment id }
+
+      (* Naming a set of section hyps *)
+      | IDENT "Collection"; id = identref; ":="; expr = section_subset_expr ->
+          { VernacNameSectionHypSet (id, expr) }
+
+      (* Requiring an already compiled module *)
+      | IDENT "Require"; export = export_token; qidl = LIST1 global ->
+          { VernacRequire (None, export, qidl) }
+      | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token
+	; qidl = LIST1 global ->
+	{ VernacRequire (Some ns, export, qidl) }
+      | IDENT "Import"; qidl = LIST1 global -> { VernacImport (false,qidl) }
+      | IDENT "Export"; qidl = LIST1 global -> { VernacImport (true,qidl) }
+      | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr ->
+	  { VernacInclude(e::l) }
+      | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type ->
+	 { warn_deprecated_include_type ~loc ();
+        VernacInclude(e::l) } ] ]
+  ;
+  export_token:
+    [ [ IDENT "Import" -> { Some false }
+      | IDENT "Export" -> { Some true }
+      |  -> { None } ] ]
+  ;
+  ext_module_type:
+    [ [ "<+"; mty = module_type_inl -> { mty } ] ]
+  ;
+  ext_module_expr:
+    [ [ "<+"; mexpr = module_expr_inl -> { mexpr } ] ]
+  ;
+  check_module_type:
+    [ [ "<:"; mty = module_type_inl -> { mty } ] ]
+  ;
+  check_module_types:
+    [ [ mtys = LIST0 check_module_type -> { mtys } ] ]
+  ;
+  of_module_type:
+    [ [ ":"; mty = module_type_inl -> { Enforce mty }
+      | mtys = check_module_types -> { Check mtys } ] ]
+  ;
+  is_module_type:
+    [ [ ":="; mty = module_type_inl ; l = LIST0 ext_module_type -> { (mty::l) }
+      | -> { [] } ] ]
+  ;
+  is_module_expr:
+    [ [ ":="; mexpr = module_expr_inl; l = LIST0 ext_module_expr -> { (mexpr::l) }
+      | -> { [] } ] ]
+  ;
+  functor_app_annot:
+    [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = INT; "]" ->
+        { InlineAt (int_of_string i) }
+      | "["; IDENT "no"; IDENT "inline"; "]" -> { NoInline }
+      | -> { DefaultInline }
+      ] ]
+  ;
+  module_expr_inl:
+    [ [ "!"; me = module_expr -> { (me,NoInline) }
+      | me = module_expr; a = functor_app_annot -> { (me,a) } ] ]
+  ;
+  module_type_inl:
+    [ [ "!"; me = module_type -> { (me,NoInline) }
+      | me = module_type; a = functor_app_annot -> { (me,a) } ] ]
+  ;
+  (* Module binder  *)
+  module_binder:
+    [ [ "("; export = export_token; idl = LIST1 identref; ":";
+         mty = module_type_inl; ")" -> { (export,idl,mty) } ] ]
+  ;
+  (* Module expressions *)
+  module_expr:
+    [ [ me = module_expr_atom -> { me }
+      | me1 = module_expr; me2 = module_expr_atom -> { CAst.make ~loc @@ CMapply (me1,me2) }
+      ] ]
+  ;
+  module_expr_atom:
+    [ [ qid = qualid -> { CAst.make ~loc @@ CMident qid } | "("; me = module_expr; ")" -> { me } ] ]
+  ;
+  with_declaration:
+    [ [ "Definition"; fqid = fullyqualid; udecl = OPT univ_decl; ":="; c = Constr.lconstr ->
+          { CWith_Definition (fqid,udecl,c) }
+      | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid ->
+	  { CWith_Module (fqid,qid) }
+      ] ]
+  ;
+  module_type:
+    [ [ qid = qualid -> { CAst.make ~loc @@ CMident qid }
+      | "("; mt = module_type; ")" -> { mt }
+      | mty = module_type; me = module_expr_atom ->
+          { CAst.make ~loc @@ CMapply (mty,me) }
+      | mty = module_type; "with"; decl = with_declaration ->
+          { CAst.make ~loc @@ CMwith (mty,decl) }
+      ] ]
+  ;
+  (* Proof using *)
+  section_subset_expr:
+    [ [ only_starredidentrefs; l = LIST0 starredidentref ->
+          { starredidentreflist_to_expr l }
+      | e = ssexpr -> { e } ]]
+  ;
+  starredidentref:
+    [ [ i = identref -> { SsSingl i }
+      | i = identref; "*" -> { SsFwdClose(SsSingl i) }
+      | "Type" -> { SsType }
+      | "Type"; "*" -> { SsFwdClose SsType } ]]
+  ;
+  ssexpr:
+    [ "35" 
+      [ "-"; e = ssexpr -> { SsCompl e } ]
+    | "50"
+      [ e1 = ssexpr; "-"; e2 = ssexpr-> { SsSubstr(e1,e2) }
+      | e1 = ssexpr; "+"; e2 = ssexpr-> { SsUnion(e1,e2) } ]
+    | "0"
+      [ i = starredidentref -> { i }
+      | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"->
+          { starredidentreflist_to_expr l }
+      | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"; "*" ->
+          { SsFwdClose(starredidentreflist_to_expr l) }
+      | "("; e = ssexpr; ")"-> { e }
+      | "("; e = ssexpr; ")"; "*" -> { SsFwdClose e } ] ]
+  ;
+END
+
+(* Extensions: implicits, coercions, etc. *)
+GRAMMAR EXTEND Gram
+  GLOBAL: gallina_ext instance_name hint_info;
+
+  gallina_ext:
+    [ [ (* Transparent and Opaque *)
+        IDENT "Transparent"; l = LIST1 smart_global ->
+          { VernacSetOpacity (Conv_oracle.transparent, l) }
+      | IDENT "Opaque"; l = LIST1 smart_global ->
+          { VernacSetOpacity (Conv_oracle.Opaque, l) }
+      | IDENT "Strategy"; l =
+          LIST1 [ v=strategy_level; "["; q=LIST1 smart_global; "]" -> { (v,q) } ] ->
+            { VernacSetStrategy l }
+      (* Canonical structure *)
+      | IDENT "Canonical"; IDENT "Structure"; qid = global ->
+          { VernacCanonical CAst.(make ~loc @@ AN qid) }
+      | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation ->
+          { VernacCanonical CAst.(make ~loc @@ ByNotation ntn) }
+      | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
+          { let s = coerce_reference_to_id qid in
+          VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),None),d) }
+
+      (* Coercions *)
+      | IDENT "Coercion"; qid = global; d = def_body ->
+          { let s = coerce_reference_to_id qid in
+          VernacDefinition ((NoDischarge,Coercion),((CAst.make (Name s)),None),d) }
+      | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
+         s = class_rawexpr; ">->"; t = class_rawexpr ->
+           { VernacIdentityCoercion (f, s, t) }
+      | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
+         t = class_rawexpr ->
+          { VernacCoercion (CAst.make ~loc @@ AN qid, s, t) }
+      | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->";
+         t = class_rawexpr ->
+          { VernacCoercion (CAst.make ~loc @@ ByNotation ntn, s, t) }
+
+      | IDENT "Context"; c = LIST1 binder ->
+          { VernacContext (List.flatten c) }
+
+      | IDENT "Instance"; namesup = instance_name; ":";
+	 expl = [ "!" -> { Decl_kinds.Implicit } | -> { Decl_kinds.Explicit } ] ; t = operconstr LEVEL "200";
+	 info = hint_info ;
+	 props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } |
+	     ":="; c = lconstr -> { Some (false,c) } | -> { None } ] ->
+	   { VernacInstance (false,snd namesup,(fst namesup,expl,t),props,info) }
+
+      | IDENT "Existing"; IDENT "Instance"; id = global;
+          info = hint_info ->
+	  { VernacDeclareInstances [id, info] }
+
+      | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global;
+        pri = OPT [ "|"; i = natural -> { i } ] ->
+         { let info = { Typeclasses.hint_priority = pri; hint_pattern = None } in
+         let insts = List.map (fun i -> (i, info)) ids in
+	  VernacDeclareInstances insts }
+
+      | IDENT "Existing"; IDENT "Class"; is = global -> { VernacDeclareClass is }
+
+      (* Arguments *)
+      | IDENT "Arguments"; qid = smart_global; 
+        args = LIST0 argument_spec_block;
+        more_implicits = OPT
+          [ ","; impl = LIST1
+            [ impl = LIST0 more_implicits_block -> { List.flatten impl } ]
+            SEP "," -> { impl }
+          ];
+        mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> { l } ] ->
+         { let mods = match mods with None -> [] | Some l -> List.flatten l in
+         let slash_position = ref None in
+         let rec parse_args i = function
+           | [] -> []
+           | `Id x :: args -> x :: parse_args (i+1) args
+           | `Slash :: args ->
+              if Option.is_empty !slash_position then
+                (slash_position := Some i; parse_args i args)
+              else
+                user_err Pp.(str "The \"/\" modifier can occur only once")
+         in
+         let args = parse_args 0 (List.flatten args) in
+         let more_implicits = Option.default [] more_implicits in
+         VernacArguments (qid, args, more_implicits, !slash_position, mods) }
+
+      | IDENT "Implicit"; "Type"; bl = reserv_list ->
+	   { VernacReserve bl }
+
+      | IDENT "Implicit"; IDENT "Types"; bl = reserv_list ->
+          { test_plural_form_types loc "Implicit Types" bl;
+           VernacReserve bl }
+
+      | IDENT "Generalizable"; 
+	   gen = [IDENT "All"; IDENT "Variables" -> { Some [] }
+	     | IDENT "No"; IDENT "Variables" -> { None }
+	     | ["Variable" -> { () } | IDENT "Variables" -> { () } ];
+		  idl = LIST1 identref -> { Some idl } ] ->
+	     { VernacGeneralizable gen } ] ]
+  ;
+  arguments_modifier:
+    [ [ IDENT "simpl"; IDENT "nomatch" -> { [`ReductionDontExposeCase] }
+      | IDENT "simpl"; IDENT "never" -> { [`ReductionNeverUnfold] }
+      | IDENT "default"; IDENT "implicits" -> { [`DefaultImplicits] }
+      | IDENT "clear"; IDENT "implicits" -> { [`ClearImplicits] }
+      | IDENT "clear"; IDENT "scopes" -> { [`ClearScopes] }
+      | IDENT "rename" -> { [`Rename] }
+      | IDENT "assert" -> { [`Assert] }
+      | IDENT "extra"; IDENT "scopes" -> { [`ExtraScopes] }
+      | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" ->
+          { [`ClearImplicits; `ClearScopes] }
+      | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" ->
+          { [`ClearImplicits; `ClearScopes] }
+      ] ]
+  ;
+  scope:
+    [ [ "%"; key = IDENT -> { key } ] ]
+  ;
+  argument_spec: [
+       [ b = OPT "!"; id = name ; s = OPT scope ->
+       { id.CAst.v, not (Option.is_empty b), Option.map (fun x -> CAst.make ~loc x) s }
+    ]
+  ];
+  (* List of arguments implicit status, scope, modifiers *)
+  argument_spec_block: [
+    [ item = argument_spec ->
+      { let name, recarg_like, notation_scope = item in
+      [`Id { name=name; recarg_like=recarg_like;
+             notation_scope=notation_scope;
+             implicit_status = NotImplicit}] }
+    | "/" -> { [`Slash] }
+    | "("; items = LIST1 argument_spec; ")"; sc = OPT scope ->
+       { let f x = match sc, x with
+         | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x
+         | Some _, Some _ -> user_err Pp.(str "scope declared twice") in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = NotImplicit}) items }
+    | "["; items = LIST1 argument_spec; "]"; sc = OPT scope ->
+       { let f x = match sc, x with
+         | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x
+         | Some _, Some _ -> user_err Pp.(str "scope declared twice") in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = Implicit}) items }
+    | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope ->
+       { let f x = match sc, x with
+         | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x
+         | Some _, Some _ -> user_err Pp.(str "scope declared twice") in
+       List.map (fun (name,recarg_like,notation_scope) ->
+           `Id { name=name; recarg_like=recarg_like;
+                 notation_scope=f notation_scope;
+                 implicit_status = MaximallyImplicit}) items }
+    ]
+  ];
+  (* Same as [argument_spec_block], but with only implicit status and names *)
+  more_implicits_block: [
+    [ name = name -> { [(name.CAst.v, Vernacexpr.NotImplicit)] }
+    | "["; items = LIST1 name; "]" ->
+       { List.map (fun name -> (name.CAst.v, Vernacexpr.Implicit)) items }
+    | "{"; items = LIST1 name; "}" ->
+       { List.map (fun name -> (name.CAst.v, Vernacexpr.MaximallyImplicit)) items }
+    ]
+  ];
+  strategy_level:
+    [ [ IDENT "expand" -> { Conv_oracle.Expand }
+      | IDENT "opaque" -> { Conv_oracle.Opaque }
+      | n=INT -> { Conv_oracle.Level (int_of_string n) }
+      | "-"; n=INT -> { Conv_oracle.Level (- int_of_string n) }
+      | IDENT "transparent" -> { Conv_oracle.transparent } ] ]
+  ;
+  instance_name:
+    [ [ name = ident_decl; sup = OPT binders ->
+          { (CAst.map (fun id -> Name id) (fst name), snd name),
+          (Option.default [] sup) }
+      | -> { ((CAst.make ~loc Anonymous), None), []  } ] ]
+  ;
+  hint_info:
+    [ [ "|"; i = OPT natural; pat = OPT constr_pattern ->
+         { { Typeclasses.hint_priority = i; hint_pattern = pat } }
+      | -> { { Typeclasses.hint_priority = None; hint_pattern = None } } ] ]
+  ;
+  reserv_list:
+    [ [ bl = LIST1 reserv_tuple -> { bl } | b = simple_reserv -> { [b] } ] ]
+  ;
+  reserv_tuple:
+    [ [ "("; a = simple_reserv; ")" -> { a } ] ]
+  ;
+  simple_reserv:
+    [ [ idl = LIST1 identref; ":"; c = lconstr -> { (idl,c) } ] ]
+  ;
+
+END
+
+GRAMMAR EXTEND Gram
+  GLOBAL: command query_command class_rawexpr gallina_ext;
+
+  gallina_ext:
+    [ [ IDENT "Export"; "Set"; table = option_table; v = option_value ->
+        { VernacSetOption (true, table, v) }
+      | IDENT "Export"; IDENT "Unset"; table = option_table ->
+          { VernacUnsetOption (true, table) }
+    ] ];
+
+  command:
+    [ [ IDENT "Comments"; l = LIST0 comment -> { VernacComments l }
+
+      (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *)
+      | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":";
+	 expl = [ "!" -> { Decl_kinds.Implicit } | -> { Decl_kinds.Explicit } ] ; t = operconstr LEVEL "200";
+	 info = hint_info ->
+	   { VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info) }
+
+      (* System directory *)
+      | IDENT "Pwd" -> { VernacChdir None }
+      | IDENT "Cd" -> { VernacChdir None }
+      | IDENT "Cd"; dir = ne_string -> { VernacChdir (Some dir) }
+
+      | IDENT "Load"; verbosely = [ IDENT "Verbose" -> { true } | -> { false } ];
+	s = [ s = ne_string -> { s } | s = IDENT -> { s } ] ->
+	  { VernacLoad (verbosely, s) }
+      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
+	  { VernacDeclareMLModule l }
+
+      | IDENT "Locate"; l = locatable -> { VernacLocate l }
+
+      (* Managing load paths *)
+      | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath ->
+	  { VernacAddLoadPath (false, dir, alias) }
+      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string;
+	  alias = as_dirpath -> { VernacAddLoadPath (true, dir, alias) }
+      | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string ->
+	  { VernacRemoveLoadPath dir }
+
+       (* For compatibility *)
+      | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  { VernacAddLoadPath (false, dir, alias) }
+      | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  { VernacAddLoadPath (true, dir, alias) }
+      | IDENT "DelPath"; dir = ne_string ->
+	  { VernacRemoveLoadPath dir }
+
+      (* Type-Checking (pas dans le refman) *)
+      | "Type"; c = lconstr -> { VernacGlobalCheck c }
+
+      (* Printing (careful factorization of entries) *)
+      | IDENT "Print"; p = printable -> { VernacPrint p }
+      | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> { VernacPrint (PrintName (qid,l)) }
+      | IDENT "Print"; IDENT "Module"; "Type"; qid = global ->
+	  { VernacPrint (PrintModuleType qid) }
+      | IDENT "Print"; IDENT "Module"; qid = global ->
+	  { VernacPrint (PrintModule qid) }
+      | IDENT "Print"; IDENT "Namespace" ; ns = dirpath ->
+          { VernacPrint (PrintNamespace ns) }
+      | IDENT "Inspect"; n = natural -> { VernacPrint (PrintInspect n) }
+
+      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
+	  { VernacAddMLPath (false, dir) }
+      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> 
+	  { VernacAddMLPath (true, dir) }
+
+      (* For acting on parameter tables *)
+      | "Set"; table = option_table; v = option_value ->
+          { VernacSetOption (false, table, v) }
+      | IDENT "Unset"; table = option_table ->
+          { VernacUnsetOption (false, table) }
+
+      | IDENT "Print"; IDENT "Table"; table = option_table ->
+	  { VernacPrintOption table }
+
+      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> { VernacAddOption ([table;field], v) }
+      (* A global value below will be hidden by a field above! *)
+      (* In fact, we give priority to secondary tables *)
+      (* No syntax for tertiary tables due to conflict *)
+      (* (but they are unused anyway) *)
+      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
+          { VernacAddOption ([table], v) }
+
+      | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value
+        -> { VernacMemOption (table, v) }
+      | IDENT "Test"; table = option_table ->
+          { VernacPrintOption table }
+
+      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
+        -> { VernacRemoveOption ([table;field], v) }
+      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
+	  { VernacRemoveOption ([table], v) } ]]
+  ;
+  query_command: (* TODO: rapprocher Eval et Check *)
+    [ [ IDENT "Eval"; r = red_expr; "in"; c = lconstr; "." ->
+          { fun g -> VernacCheckMayEval (Some r, g, c) }
+      | IDENT "Compute"; c = lconstr; "." ->
+	  { fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) }
+      | IDENT "Check"; c = lconstr; "." ->
+	 { fun g -> VernacCheckMayEval (None, g, c) }
+      (* Searching the environment *)
+      | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." ->
+         { fun g -> VernacPrint (PrintAbout (qid,l,g)) }
+      | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." ->
+	  { fun g -> VernacSearch (SearchHead c,g, l) }
+      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." ->
+	  { fun g -> VernacSearch (SearchPattern c,g, l) }
+      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." ->
+	  { fun g -> VernacSearch (SearchRewrite c,g, l) }
+      | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." ->
+	  { let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) }
+      (* compatibility: SearchAbout *)
+      | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." ->
+	  { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) }
+      (* compatibility: SearchAbout with "[ ... ]" *)
+      | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]";
+	l = in_or_out_modules; "." ->
+         { fun g -> VernacSearch (SearchAbout sl,g, l) }
+      ] ]
+  ;
+  printable:
+    [ [ IDENT "Term"; qid = smart_global; l = OPT univ_name_list -> { PrintName (qid,l) }
+      | IDENT "All" -> { PrintFullContext }
+      | IDENT "Section"; s = global -> { PrintSectionContext s }
+      | IDENT "Grammar"; ent = IDENT ->
+          (* This should be in "syntax" section but is here for factorization*)
+	  { PrintGrammar ent }
+      | IDENT "LoadPath"; dir = OPT dirpath -> { PrintLoadPath dir }
+      | IDENT "Modules" ->
+          { user_err Pp.(str "Print Modules is obsolete; use Print Libraries instead") }
+      | IDENT "Libraries" -> { PrintModules }
+
+      | IDENT "ML"; IDENT "Path" -> { PrintMLLoadPath }
+      | IDENT "ML"; IDENT "Modules" -> { PrintMLModules }
+      | IDENT "Debug"; IDENT "GC" -> { PrintDebugGC }
+      | IDENT "Graph" -> { PrintGraph }
+      | IDENT "Classes" -> {  PrintClasses }
+      | IDENT "TypeClasses" -> { PrintTypeClasses }
+      | IDENT "Instances"; qid = smart_global -> { PrintInstances qid }
+      | IDENT "Coercions" -> { PrintCoercions }
+      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
+         -> { PrintCoercionPaths (s,t) }
+      | IDENT "Canonical"; IDENT "Projections" -> { PrintCanonicalConversions }
+      | IDENT "Tables" -> { PrintTables }
+      | IDENT "Options" -> { PrintTables (* A Synonymous to Tables *) }
+      | IDENT "Hint" -> { PrintHintGoal }
+      | IDENT "Hint"; qid = smart_global -> { PrintHint qid }
+      | IDENT "Hint"; "*" -> { PrintHintDb }
+      | IDENT "HintDb"; s = IDENT -> { PrintHintDbName s }
+      | IDENT "Scopes" -> { PrintScopes }
+      | IDENT "Scope"; s = IDENT -> { PrintScope s }
+      | IDENT "Visibility"; s = OPT IDENT -> { PrintVisibility s }
+      | IDENT "Implicit"; qid = smart_global -> { PrintImplicit qid }
+      | IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (false, fopt) }
+      | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (true, fopt) }
+      | IDENT "Assumptions"; qid = smart_global -> { PrintAssumptions (false, false, qid) }
+      | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (true, false, qid) }
+      | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (false, true, qid) }
+      | IDENT "All"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (true, true, qid) }
+      | IDENT "Strategy"; qid = smart_global -> { PrintStrategy (Some qid) }
+      | IDENT "Strategies" -> { PrintStrategy None } ] ]
+  ;
+  class_rawexpr:
+    [ [ IDENT "Funclass" -> { FunClass }
+      | IDENT "Sortclass" -> { SortClass }
+      | qid = smart_global -> { RefClass qid } ] ]
+  ;
+  locatable:
+    [ [ qid = smart_global -> { LocateAny qid }
+      | IDENT "Term"; qid = smart_global -> { LocateTerm qid }
+      | IDENT "File"; f = ne_string -> { LocateFile f }
+      | IDENT "Library"; qid = global -> { LocateLibrary qid }
+      | IDENT "Module"; qid = global -> { LocateModule qid } ] ]
+  ;
+  option_value:
+    [ [ -> { BoolValue true }
+      | n  = integer   -> { IntValue (Some n) }
+      | s  = STRING    -> { StringValue s } ] ]
+  ;
+  option_ref_value:
+    [ [ id = global   -> { QualidRefValue id }
+      | s  = STRING   -> { StringRefValue s } ] ]
+  ;
+  option_table:
+    [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]]
+  ;
+  as_dirpath:
+    [ [ d = OPT [ "as"; d = dirpath -> { d } ] -> { d } ] ]
+  ;
+  ne_in_or_out_modules:
+    [ [ IDENT "inside"; l = LIST1 global -> { SearchInside l }
+      | IDENT "outside"; l = LIST1 global -> { SearchOutside l } ] ]
+  ;
+  in_or_out_modules:
+    [ [ m = ne_in_or_out_modules -> { m }
+      | -> { SearchOutside [] } ] ]
+  ;
+  comment:
+    [ [ c = constr -> { CommentConstr c }
+      | s = STRING -> { CommentString s }
+      | n = natural -> { CommentInt n } ] ]
+  ;
+  positive_search_mark:
+    [ [ "-" -> { false } | -> { true } ] ]
+  ;
+  scope:
+    [ [ "%"; key = IDENT -> { key } ] ]
+  ;
+  searchabout_query:
+    [ [ b = positive_search_mark; s = ne_string; sc = OPT scope ->
+            { (b, SearchString (s,sc)) }
+      | b = positive_search_mark; p = constr_pattern ->
+            { (b, SearchSubPattern p) }
+      ] ]
+  ;
+  searchabout_queries:
+    [ [ m = ne_in_or_out_modules -> { ([],m) }
+      | s = searchabout_query; l = searchabout_queries ->
+        { let (sl,m) = l in (s::sl,m) }
+      | -> { ([],SearchOutside []) }
+      ] ]
+  ;
+  univ_name_list:
+    [ [  "@{" ; l = LIST0 name; "}" -> { l } ] ]
+  ;
+END
+
+GRAMMAR EXTEND Gram
+  GLOBAL: command;
+
+  command:
+    [ [
+(* State management *)
+        IDENT "Write"; IDENT "State"; s = IDENT -> { VernacWriteState s }
+      | IDENT "Write"; IDENT "State"; s = ne_string -> { VernacWriteState s }
+      | IDENT "Restore"; IDENT "State"; s = IDENT -> { VernacRestoreState s }
+      | IDENT "Restore"; IDENT "State"; s = ne_string -> { VernacRestoreState s }
+
+(* Resetting *)
+      | IDENT "Reset"; IDENT "Initial" -> { VernacResetInitial }
+      | IDENT "Reset"; id = identref -> { VernacResetName id }
+      | IDENT "Back" -> { VernacBack 1 }
+      | IDENT "Back"; n = natural -> { VernacBack n }
+      | IDENT "BackTo"; n = natural -> { VernacBackTo n }
+
+(* Tactic Debugger *)
+      |	IDENT "Debug"; IDENT "On" ->
+          { VernacSetOption (false, ["Ltac";"Debug"], BoolValue true) }
+
+      |	IDENT "Debug"; IDENT "Off" ->
+          { VernacSetOption (false, ["Ltac";"Debug"], BoolValue false) }
+
+(* registration of a custom reduction *)
+
+      | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":=";
+         r = red_expr ->
+	   { VernacDeclareReduction (s,r) }
+
+(* factorized here, though relevant for syntax extensions *)
+
+      | IDENT "Declare"; IDENT "Custom"; IDENT "Entry"; s = IDENT ->
+           { VernacDeclareCustomEntry s }
+
+ ] ];
+    END
+
+(* Grammar extensions *)
+
+GRAMMAR EXTEND Gram
+  GLOBAL: syntax;
+
+  syntax:
+   [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT ->
+         { VernacOpenCloseScope (true,sc) }
+
+     | IDENT "Close"; IDENT "Scope"; sc = IDENT ->
+         { VernacOpenCloseScope (false,sc) }
+
+     | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
+	 { VernacDelimiters (sc, Some key) }
+     | IDENT "Undelimit"; IDENT "Scope"; sc = IDENT ->
+	 { VernacDelimiters (sc, None) }
+
+     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with";
+       refl = LIST1 class_rawexpr -> { VernacBindScope (sc,refl) }
+
+     | IDENT "Infix"; op = ne_lstring; ":="; p = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ];
+	 sc = OPT [ ":"; sc = IDENT -> { sc } ] ->
+         { VernacInfix ((op,modl),p,sc) }
+     | IDENT "Notation"; id = identref;
+	 idl = LIST0 ident; ":="; c = constr; b = only_parsing ->
+           { VernacSyntacticDefinition
+             (id,(idl,c),b) }
+     | IDENT "Notation"; s = lstring; ":=";
+	 c = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ];
+	 sc = OPT [ ":"; sc = IDENT -> { sc } ] ->
+           { VernacNotation (c,(s,modl),sc) }
+     | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING ->
+           { VernacNotationAddFormat (n,s,fmt) }
+
+     | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring;
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] ->
+           { let s = CAst.map (fun s -> "x '"^s^"' y") s in
+           VernacSyntaxExtension (true,(s,l)) }
+
+     | IDENT "Reserved"; IDENT "Notation";
+	 s = ne_lstring;
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]
+         -> { VernacSyntaxExtension (false, (s,l)) }
+
+     (* "Print" "Grammar" should be here but is in "command" entry in order
+        to factorize with other "Print"-based vernac entries *)
+  ] ]
+  ;
+  only_parsing:
+    [ [ "("; IDENT "only"; IDENT "parsing"; ")" ->
+         { Some Flags.Current }
+      | "("; IDENT "compat"; s = STRING; ")" ->
+         { Some (parse_compat_version s) }
+      | -> { None } ] ]
+  ;
+  level:
+    [ [ IDENT "level"; n = natural -> { NumLevel n }
+      | IDENT "next"; IDENT "level" -> { NextLevel } ] ]
+  ;
+  syntax_modifier:
+    [ [ "at"; IDENT "level"; n = natural -> { SetLevel n }
+      | "in"; IDENT "custom"; x = IDENT -> { SetCustomEntry (x,None) }
+      | "in"; IDENT "custom"; x = IDENT; "at"; IDENT "level"; n = natural ->
+         { SetCustomEntry (x,Some n) }
+      | IDENT "left"; IDENT "associativity" -> { SetAssoc LeftA }
+      | IDENT "right"; IDENT "associativity" -> { SetAssoc RightA }
+      | IDENT "no"; IDENT "associativity" -> { SetAssoc NonA }
+      | IDENT "only"; IDENT "printing" -> { SetOnlyPrinting }
+      | IDENT "only"; IDENT "parsing" -> { SetOnlyParsing }
+      | IDENT "compat"; s = STRING ->
+        { SetCompatVersion (parse_compat_version s) }
+      | IDENT "format"; s1 = [s = STRING -> { CAst.make ~loc s } ];
+                        s2 = OPT [s = STRING -> { CAst.make ~loc s } ] ->
+          { begin match s1, s2 with
+          | { CAst.v = k }, Some s -> SetFormat(k,s)
+          | s, None -> SetFormat ("text",s) end }
+      | x = IDENT; ","; l = LIST1 [id = IDENT -> { id } ] SEP ","; "at";
+        lev = level -> { SetItemLevel (x::l,None,Some lev) }
+      | x = IDENT; "at"; lev = level -> { SetItemLevel ([x],None,Some lev) }
+      | x = IDENT; "at"; lev = level; b = constr_as_binder_kind ->
+        { SetItemLevel ([x],Some b,Some lev) }
+      | x = IDENT; b = constr_as_binder_kind -> { SetItemLevel ([x],Some b,None) }
+      | x = IDENT; typ = syntax_extension_type -> { SetEntryType (x,typ) }
+    ] ]
+  ;
+  syntax_extension_type:
+    [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal }
+      | IDENT "bigint" -> { ETBigint }
+      | IDENT "binder" -> { ETBinder true }
+      | IDENT "constr" -> { ETConstr (InConstrEntry,None,None) }
+      | IDENT "constr"; n = OPT at_level; b = OPT constr_as_binder_kind -> { ETConstr (InConstrEntry,b,n) }
+      | IDENT "pattern" -> { ETPattern (false,None) }
+      | IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (false,Some n) }
+      | IDENT "strict"; IDENT "pattern" -> { ETPattern (true,None) }
+      | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (true,Some n) }
+      | IDENT "closed"; IDENT "binder" -> { ETBinder false }
+      | IDENT "custom"; x = IDENT; n = OPT at_level; b = OPT constr_as_binder_kind ->
+           { ETConstr (InCustomEntry x,b,n) }
+    ] ]
+  ;
+  at_level:
+    [ [ "at"; n = level -> { n } ] ]
+  ;
+  constr_as_binder_kind:
+    [ [ "as"; IDENT "ident" -> { Notation_term.AsIdent }
+      | "as"; IDENT "pattern" -> { Notation_term.AsIdentOrPattern }
+      | "as"; IDENT "strict"; IDENT "pattern" -> { Notation_term.AsStrictPattern } ] ]
+  ;
+END
diff --git a/vernac/himsg.ml b/vernac/himsg.ml
index 2d2f1cd2..d232f086 100644
--- a/vernac/himsg.ml
+++ b/vernac/himsg.ml
@@ -75,11 +75,7 @@ let rec contract3' env sigma a b c = function
   | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities
   | UnifUnivInconsistency _ as x -> contract3 env sigma a b c, x
   | CannotSolveConstraint ((pb,env',t,u),x) ->
-      let t = EConstr.of_constr t in
-      let u = EConstr.of_constr u in
       let env',t,u = contract2 env' sigma t u in
-      let t = EConstr.Unsafe.to_constr t in
-      let u = EConstr.Unsafe.to_constr u in
       let y,x = contract3' env sigma a b c x in
       y,CannotSolveConstraint ((pb,env',t,u),x)
 
@@ -90,7 +86,7 @@ let j_nf_betaiotaevar env sigma j =
     uj_type = Reductionops.nf_betaiota env sigma j.uj_type }
 
 let jv_nf_betaiotaevar env sigma jl =
-  Array.map (fun j -> j_nf_betaiotaevar env sigma j) jl
+  Array.Smart.map (fun j -> j_nf_betaiotaevar env sigma j) jl
 
 (** Printers *)
 
@@ -198,12 +194,6 @@ let rec pr_disjunction pr = function
   | 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 open EConstr in
   let env = make_all_name_different env sigma in
@@ -266,7 +256,7 @@ let explain_ill_formed_branch env sigma c ci actty expty =
   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) ++
+  quote (pr_pconstructor env sigma ci) ++
   spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++
   str "which should be" ++ brk(1,1) ++ pe ++ str "."
 
@@ -318,12 +308,10 @@ let explain_unification_error env sigma p1 p2 = function
      | UnifUnivInconsistency p ->
         if !Constrextern.print_universes then
 	  [str "universe inconsistency: " ++
-          Univ.explain_universe_inconsistency Universes.pr_with_global_universes p]
+          Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes p]
 	else
           [str "universe inconsistency"]
      | CannotSolveConstraint ((pb,env,t,u),e) ->
-        let t = EConstr.of_constr t in
-        let u = EConstr.of_constr u in
         let env = make_all_name_different env sigma in
         (strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++
         str " == " ++ pr_leconstr_env env sigma u)
@@ -403,11 +391,10 @@ let explain_unexpected_type env sigma actual_type expected_type =
   str "where" ++ spc () ++ prexp ++ str " was expected."
 
 let explain_not_product env sigma c =
-  let c = EConstr.to_constr sigma c in
-  let pr = pr_lconstr_env env sigma c in
+  let pr = pr_econstr_env env sigma c in
   str "The type of this term is a product" ++ spc () ++
   str "while it is expected to be" ++
-  (if Constr.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
+  (if EConstr.isType sigma c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
 
 (* TODO: use the names *)
 (* (co)fixpoints *)
@@ -526,11 +513,15 @@ let pr_trailing_ne_context_of env sigma =
   then str "."
   else (str " in environment:"++ pr_context_unlimited env sigma)
 
-let rec explain_evar_kind env sigma evk ty = function
+let rec explain_evar_kind env sigma evk ty =
+    let open Evar_kinds in
+    function
   | Evar_kinds.NamedHole id ->
       strbrk "the existential variable named " ++ Id.print id
-  | Evar_kinds.QuestionMark _ ->
+  | Evar_kinds.QuestionMark {qm_record_field=None} ->
       strbrk "this placeholder of type " ++ ty
+  | Evar_kinds.QuestionMark {qm_record_field=Some {fieldname; recordname}} ->
+          str "field " ++ (Printer.pr_constant env fieldname) ++ str " of record " ++ (Printer.pr_inductive env recordname)
   | Evar_kinds.CasesType false ->
       strbrk "the type of this pattern-matching problem"
   | Evar_kinds.CasesType true ->
@@ -559,23 +550,29 @@ let rec explain_evar_kind env sigma evk ty = function
   | Evar_kinds.VarInstance id ->
       strbrk "an instance of type " ++ ty ++
       str " for the variable " ++ Id.print id
-  | Evar_kinds.SubEvar evk' ->
+  | Evar_kinds.SubEvar (where,evk') ->
       let evi = Evd.find sigma evk' in
       let pc = match evi.evar_body with
-      | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c)
+      | Evar_defined c -> pr_leconstr_env env sigma c
       | Evar_empty -> assert false in
-      let ty' = EConstr.of_constr evi.evar_concl in
+      let ty' = evi.evar_concl in
+      (match where with
+      | Some Evar_kinds.Body -> str "the body of "
+      | Some Evar_kinds.Domain -> str "the domain of "
+      | Some Evar_kinds.Codomain -> str "the codomain of "
+      | None ->
       pr_existential_key sigma evk ++ str " of type " ++ ty ++
       str " in the partial instance " ++ pc ++
-      str " found for " ++ explain_evar_kind env sigma evk'
+      str " found for ") ++
+      explain_evar_kind env sigma evk'
       (pr_leconstr_env env sigma ty') (snd evi.evar_source)
 
 let explain_typeclass_resolution env sigma evi k =
-  match Typeclasses.class_of_constr sigma (EConstr.of_constr evi.evar_concl) with
+  match Typeclasses.class_of_constr sigma 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_leconstr_env env sigma evi.evar_concl ++
       pr_trailing_ne_context_of env sigma
   | _ -> mt()
 
@@ -584,14 +581,14 @@ let explain_placeholder_kind env sigma c e =
   | Some (SeveralInstancesFound n) ->
       strbrk " (several distinct possible type class instances found)"
   | None ->
-      match Typeclasses.class_of_constr sigma (EConstr.of_constr c) with
+      match Typeclasses.class_of_constr sigma 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 type_of_hole = pr_leconstr_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) ++
@@ -634,8 +631,7 @@ let explain_refiner_cannot_generalize env sigma ty =
   pr_leconstr_env env sigma ty ++ str "."
 
 let explain_no_occurrence_found env sigma c id =
-  let c = EConstr.to_constr sigma c in
-  str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++
+  str "Found no subterm matching " ++ pr_leconstr_env env sigma c ++
   str " in " ++
     (match id with
       | Some id -> Id.print id
@@ -682,6 +678,11 @@ let explain_unsatisfied_constraints env sigma cst =
     Univ.pr_constraints (Termops.pr_evd_level sigma) cst ++ 
     spc () ++ str "(maybe a bugged tactic)."
 
+let explain_undeclared_universe env sigma l =
+  strbrk "Undeclared universe: " ++
+    Termops.pr_evd_level sigma l ++
+    spc () ++ str "(maybe a bugged tactic)."
+
 let explain_type_error env sigma err =
   let env = make_all_name_different env sigma in
   match err with
@@ -719,6 +720,8 @@ let explain_type_error env sigma err =
       explain_wrong_case_info env ind ci
   | UnsatisfiedConstraints cst ->
       explain_unsatisfied_constraints env sigma cst
+  | UndeclaredUniverse l ->
+     explain_undeclared_universe env sigma l
 
 let pr_position (cl,pos) =
   let clpos = match cl with
@@ -760,7 +763,7 @@ let pr_constraints printenv env sigma evars cstrs =
       let evs =
         prlist
         (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++
-            str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l
+            str " : " ++ pr_leconstr_env env' sigma evi.evar_concl ++ fnl ()) l
       in
       h 0 (pe ++ evs ++ pr_evar_constraints sigma cstrs)
     else
@@ -849,9 +852,9 @@ let explain_not_match_error = function
     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 () ++
+    quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) typ2) ++ spc () ++
     str "but found type" ++ spc () ++
-    quote (Printer.safe_pr_lconstr_env env Evd.empty typ1)
+    quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) typ1)
   | NotSameConstructorNamesField ->
     str "constructor names differ"
   | NotSameInductiveNameInBlockField ->
@@ -884,12 +887,12 @@ let explain_not_match_error = function
     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
+      Univ.explain_universe_inconsistency UnivNames.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 () ++
+      quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t1) ++ spc () ++
       str "compared to " ++ spc () ++
-      quote (Printer.safe_pr_lconstr_env env Evd.empty t2)
+      quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t2)
   | IncompatibleConstraints cst ->
     str " the expected (polymorphic) constraints do not imply " ++
       let cst = Univ.AUContext.instantiate (Univ.AUContext.instance cst) cst in
@@ -1009,8 +1012,9 @@ let explain_module_internalization_error = function
 (* Typeclass errors *)
 
 let explain_not_a_class env c =
-  let c = EConstr.to_constr Evd.empty c in
-  pr_constr_env env Evd.empty c ++ str" is not a declared type class."
+  let sigma = Evd.from_env env in
+  let c = EConstr.to_constr sigma c in
+  pr_constr_env env sigma c ++ str" is not a declared type class."
 
 let explain_unbound_method env cid { CAst.v = id } =
   str "Unbound method name " ++ Id.print (id) ++ spc () ++
@@ -1023,14 +1027,13 @@ let pr_constr_exprs exprs =
 
 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) ++
+    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env (Evd.from_env env) 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 *)
 
@@ -1085,19 +1088,19 @@ let explain_refiner_error env sigma = function
 (* 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
+  let pc = pr_lconstr_env env (Evd.from_env env) c in
+  let pv = pr_lconstr_env env (Evd.from_env env) 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
+  let pc = pr_lconstr_env env (Evd.from_env env) c in
+  let pv = pr_lconstr_env env (Evd.from_env env) 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 pv = pr_lconstr_env env (Evd.from_env env) v in
   let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (** FIXME *) 0 in
   str "The type of constructor" ++ brk(1,1) ++ Id.print id ++ brk(1,1) ++
   str "is not valid;" ++ brk(1,1) ++
@@ -1117,12 +1120,12 @@ let error_ill_formed_constructor env id c v nparams nargs =
 
 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 (EConstr.of_constr c))
+  quote (pr_goal_concl_style_env env (Evd.from_env env) (EConstr.of_constr 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
+  let pv1 = pr_lconstr_env env (Evd.from_env env) v1 in
+  let pv2 = pr_lconstr_env env (Evd.from_env env) v2 in
   str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
   str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "."
 
@@ -1140,7 +1143,7 @@ let error_same_names_overlap idl =
   prlist_with_sep pr_comma Id.print idl ++ str "."
 
 let error_not_an_arity env c =
-  str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++
+  str "The type" ++ spc () ++ pr_lconstr_env env (Evd.from_env env) c ++ spc () ++
   str "is not an arity."
 
 let error_bad_entry () =
@@ -1230,12 +1233,7 @@ let explain_wrong_numarg_inductive env ind n =
   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."
+  str "Pattern \"" ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) ++ strbrk "\" is redundant in this clause."
 
 let explain_non_exhaustive env pats =
   str "Non exhaustive pattern-matching: no clause found for " ++
@@ -1307,6 +1305,7 @@ let map_ptype_error f = function
 | IllTypedRecBody (n, na, jv, t) ->
   IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t)
 | UnsatisfiedConstraints g -> UnsatisfiedConstraints g
+| UndeclaredUniverse l -> UndeclaredUniverse l
 
 let explain_reduction_tactic_error = function
   | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) ->
@@ -1314,4 +1313,14 @@ let explain_reduction_tactic_error = function
       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
+      explain_type_error env' (Evd.from_env env') e
+
+let explain_numeral_notation_error env sigma = function
+  | Notation.UnexpectedTerm c ->
+    (strbrk "Unexpected term " ++
+     pr_constr_env env sigma c ++
+     strbrk " while parsing a numeral notation.")
+  | Notation.UnexpectedNonOptionTerm c ->
+    (strbrk "Unexpected non-option term " ++
+     pr_constr_env env sigma c ++
+     strbrk " while parsing a numeral notation.")
diff --git a/vernac/himsg.mli b/vernac/himsg.mli
index 0e20d18c..02b3c455 100644
--- a/vernac/himsg.mli
+++ b/vernac/himsg.mli
@@ -25,6 +25,8 @@ val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> Pp.t
 
 val explain_inductive_error : inductive_error -> Pp.t
 
+val explain_mismatched_contexts : env -> contexts -> Constrexpr.constr_expr list -> Constr.rel_context -> Pp.t
+
 val explain_typeclass_error : env -> typeclass_error -> Pp.t
 
 val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t
@@ -44,3 +46,5 @@ val explain_module_internalization_error :
 
 val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error
 val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error
+
+val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t
diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml
index 49414862..e86e1087 100644
--- a/vernac/indschemes.ml
+++ b/vernac/indschemes.ml
@@ -380,7 +380,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort =
 	 match inst with
 	 | None ->
 	    let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in
-	    let u, ctx = Universes.fresh_instance_from ctx None in
+            let u, ctx = UnivGen.fresh_instance_from ctx None in
             let evd = Evd.from_ctx (UState.of_context_set ctx) in
 	      evd, (ind,u), Some u
 	 | Some ui -> evd, (ind, ui), inst
diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli
index 43915788..ebfc76de 100644
--- a/vernac/indschemes.mli
+++ b/vernac/indschemes.mli
@@ -36,17 +36,17 @@ val declare_rewriting_schemes : inductive -> unit
  *)
 
 val do_mutual_induction_scheme : ?force_mutual:bool ->
-  (Misctypes.lident * bool * inductive * Sorts.family) list -> unit
+  (lident * bool * inductive * Sorts.family) list -> unit
 
 (** Main calls to interpret the Scheme command *)
 
-val do_scheme : (Misctypes.lident option * scheme) list -> unit
+val do_scheme : (lident option * scheme) list -> unit
 
 (** Combine a list of schemes into a conjunction of them *)
 
 val build_combined_scheme : env -> Constant.t list -> Evd.evar_map * constr * types
 
-val do_combined_scheme : Misctypes.lident -> Misctypes.lident list -> unit
+val do_combined_scheme : lident -> lident list -> unit
 
 (** Hook called at each inductive type definition *)
 
diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml
index 30dd6ec7..880a11be 100644
--- a/vernac/lemmas.ml
+++ b/vernac/lemmas.ml
@@ -34,7 +34,7 @@ open Impargs
 module RelDecl = Context.Rel.Declaration
 module NamedDecl = Context.Named.Declaration
 
-type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a
+type 'a declaration_hook = Decl_kinds.locality -> GlobRef.t -> 'a
 let mk_hook hook = hook
 let call_hook fix_exn hook l c =
   try hook l c
@@ -71,17 +71,13 @@ let adjust_guardness_conditions const = function
 	  List.interval 0 (List.length ((lam_assum c))))
 	  lemma_guard (Array.to_list fixdefs) in
 *)
-              let add c cb e =
-                let exists c e =
-                  try ignore(Environ.lookup_constant c e); true
-                  with Not_found -> false in 
-                if exists c e then e else Environ.add_constant c cb e in
-              let env = List.fold_left (fun env { eff } ->
-                match eff with
-                | SEsubproof (c, cb,_) -> add c cb env
-                | SEscheme (l,_) ->
-                    List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l)
-                env (Safe_typing.side_effects_of_private_constants eff) in
+              let fold env eff =
+                try
+                  let _ = Environ.lookup_constant eff.seff_constant env in
+                  env
+                with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env
+              in
+              let env = List.fold_left fold env (Safe_typing.side_effects_of_private_constants eff) in
               let indexes =
                 search_guard env
                   possible_indexes fixdecls in
@@ -334,8 +330,8 @@ let universe_proof_terminator compute_guard hook =
       Feedback.feedback Feedback.AddedAxiom
   | Proved (opaque,idopt,proof) ->
       let is_opaque, export_seff = match opaque with
-        | Vernacexpr.Transparent -> false, true
-        | Vernacexpr.Opaque      -> true, false
+        | Transparent -> false, true
+        | Opaque      -> true, false
       in
       let proof = get_proof proof compute_guard
         (hook (Some (proof.Proof_global.universes))) is_opaque in
@@ -436,7 +432,7 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook =
 let start_proof_com ?inference_hook kind thms hook =
   let env0 = Global.env () in
   let decl = fst (List.hd thms) in
-  let evd, decl = Univdecls.interp_univ_decl_opt env0 (snd decl) in
+  let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in
   let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) ->
     let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in
     let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in
@@ -451,12 +447,12 @@ let start_proof_com ?inference_hook kind thms hook =
            (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps'))))
       evd thms in
   let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in
-  let evd, _nf = Evarutil.nf_evars_and_universes evd in
+  let evd = Evd.minimize_universes evd in
   (* XXX: This nf_evar is critical too!! We are normalizing twice if
      you look at the previous lines... *)
   let thms = List.map (fun (n, (t, info)) -> (n, (nf_evar evd t, info))) thms in
   let () =
-    let open Misctypes in
+    let open UState in
     if not (decl.univdecl_extensible_instance && decl.univdecl_extensible_constraints) then
        ignore (Evd.check_univ_decl ~poly:(pi2 kind) evd decl)
   in
diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli
index ad4c278e..c9e4876e 100644
--- a/vernac/lemmas.mli
+++ b/vernac/lemmas.mli
@@ -13,21 +13,21 @@ open Decl_kinds
 
 type 'a declaration_hook
 val mk_hook :
-  (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook
+  (Decl_kinds.locality -> GlobRef.t -> 'a) -> 'a declaration_hook
 
 val call_hook :
-  Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a
+  Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> GlobRef.t -> 'a
 
 (** A hook start_proof calls on the type of the definition being started *)
 val set_start_hook : (EConstr.types -> unit) -> unit
 
-val start_proof : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map ->
+val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map ->
   ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) ->
   ?sign:Environ.named_context_val -> EConstr.types ->
   ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> 
    unit declaration_hook -> unit
 
-val start_proof_univs : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map ->
+val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map ->
   ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> unit declaration_hook) -> Proof_global.proof_terminator) ->
   ?sign:Environ.named_context_val -> EConstr.types ->
   ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> 
@@ -39,7 +39,7 @@ val start_proof_com :
   unit declaration_hook -> unit
 
 val start_proof_with_initialization :
-  goal_kind -> Evd.evar_map -> Univdecls.universe_decl ->
+  goal_kind -> Evd.evar_map -> UState.universe_decl ->
   (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option ->
   (Id.t (* name of thm *) *
      (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list
diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml
index 8c9d8f6b..d66a1214 100644
--- a/vernac/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -15,6 +15,7 @@ open Names
 open Constrexpr
 open Constrexpr_ops
 open Notation_term
+open Notation_gram
 open Notation_ops
 open Ppextend
 open Extend
@@ -48,7 +49,7 @@ 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 () = Pcoq.Gram.entry_print ft e in
+  let () = Pcoq.Entry.print ft e in
   str (Buffer.contents entry_buf)
 
 let pr_registered_grammar name =
@@ -76,22 +77,22 @@ let pr_grammar = function
       pr_entry Pcoq.Constr.pattern
   | "vernac" ->
       str "Entry vernac_control is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.vernac_control ++
+      pr_entry Pvernac.Vernac_.vernac_control ++
       str "Entry command is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.command ++
+      pr_entry Pvernac.Vernac_.command ++
       str "Entry syntax is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.syntax ++
+      pr_entry Pvernac.Vernac_.syntax ++
       str "Entry gallina is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.gallina ++
+      pr_entry Pvernac.Vernac_.gallina ++
       str "Entry gallina_ext is" ++ fnl () ++
-      pr_entry Pcoq.Vernac_.gallina_ext
+      pr_entry Pvernac.Vernac_.gallina_ext
   | name -> pr_registered_grammar name
 
 (**********************************************************************)
 (* Parse a format (every terminal starting with a letter or a single
    quote (except a single quote alone) must be quoted) *)
 
-let parse_format ({CAst.loc;v=str} : Misctypes.lstring) =
+let parse_format ({CAst.loc;v=str} : lstring) =
   let len = String.length str in
   (* TODO: update the line of the location when the string contains newlines *)
   let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in
@@ -282,20 +283,30 @@ let error_not_same_scope x y =
 (**********************************************************************)
 (* Build pretty-printing rules                                        *)
 
+let pr_notation_entry = function
+  | InConstrEntry -> str "constr"
+  | InCustomEntry s -> str "custom " ++ str s
+
 let prec_assoc = function
   | RightA -> (L,E)
   | LeftA -> (E,L)
   | NonA -> (L,L)
 
-let precedence_of_position_and_level from = function
+let precedence_of_position_and_level from_level = function
   | NumLevel n, BorderProd (_,None) -> n, Prec n
   | NumLevel n, BorderProd (b,Some a) ->
       n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp
   | NumLevel n, InternalProd -> n, Prec n
-  | NextLevel, _ -> from, L
-
-let precedence_of_entry_type from = function
-  | ETConstr x | ETConstrAsBinder (_,x) -> precedence_of_position_and_level from x
+  | NextLevel, _ -> from_level, L
+
+let precedence_of_entry_type (from_custom,from_level) = function
+  | ETConstr (custom,_,x) when notation_entry_eq custom from_custom ->
+    precedence_of_position_and_level from_level x
+  | ETConstr (custom,_,(NumLevel n,_)) -> n, Prec n
+  | ETConstr (custom,_,(NextLevel,_)) ->
+    user_err (strbrk "\"next level\" is only for sub-expressions in the same entry as where the notation is (" ++
+              quote (pr_notation_entry custom) ++ strbrk " is different from " ++
+              quote (pr_notation_entry from_custom) ++ str ").")
   | ETPattern (_,n) -> let n = match n with None -> 0 | Some n -> n in n, Prec n
   | _ -> 0, E (* should not matter *)
 
@@ -366,15 +377,14 @@ let unparsing_metavar i from typs =
   let x = List.nth typs (i-1) in
   let prec = snd (precedence_of_entry_type from x) in
   match x with
-  | ETConstr _ | ETConstrAsBinder _ | ETReference | ETBigint ->
+  | ETConstr _ | ETGlobal | ETBigint ->
      UnpMetaVar (i,prec)
   | ETPattern _ ->
      UnpBinderMetaVar (i,prec)
-  | ETName ->
-     UnpBinderMetaVar (i,Prec 0)
+  | ETIdent ->
+     UnpBinderMetaVar (i,prec)
   | ETBinder isopen ->
      assert false
-  | ETOther _ -> failwith "TODO"
 
 (* Heuristics for building default printing rules *)
 
@@ -560,11 +570,10 @@ let hunks_of_format (from,(vars,typs)) symfmt =
 (**********************************************************************)
 (* Build parsing rules                                                *)
 
-let assoc_of_type n (_,typ) = precedence_of_entry_type n typ
+let assoc_of_type from n (_,typ) = precedence_of_entry_type (from,n) typ
 
 let is_not_small_constr = function
     ETProdConstr _ -> true
-  | ETProdOther("constr","binder_constr") -> true
   | _ -> false
 
 let rec define_keywords_aux = function
@@ -594,9 +603,9 @@ let distribute a ll = List.map (fun l -> a @ l) ll
      t;sep;t;...;t;sep;t;...;t;sep;t (p+n times)
      t;sep;t;...;t;sep;t;...;t;sep;t;LIST1(t,sep) *)
 
-let expand_list_rule typ tkl x n p ll =
+let expand_list_rule s typ tkl x n p ll =
   let camlp5_message_name = Some (add_suffix x ("_"^string_of_int n)) in
-  let main = GramConstrNonTerminal (ETProdConstr typ, camlp5_message_name) in
+  let main = GramConstrNonTerminal (ETProdConstr (s,typ), camlp5_message_name) in
   let tks = List.map (fun x -> GramConstrTerminal x) tkl in
   let rec aux i hds ll =
   if i < p then aux (i+1) (main :: tks @ hds) ll
@@ -612,7 +621,7 @@ let expand_list_rule typ tkl x n p ll =
 
 let is_constr_typ typ x etyps =
   match List.assoc x etyps with
-  | ETConstr typ' | ETConstrAsBinder (_,typ') -> typ = typ'
+  | ETConstr (_,_,typ') -> typ = typ'
   | _ -> false
 
 let include_possible_similar_trailing_pattern typ etyps sl l =
@@ -626,13 +635,12 @@ let include_possible_similar_trailing_pattern typ etyps sl l =
   try_aux 0 l
 
 let prod_entry_type = function
-  | ETName -> ETProdName
-  | ETReference -> ETProdReference
+  | ETIdent -> ETProdName
+  | ETGlobal -> ETProdReference
   | ETBigint -> ETProdBigint
   | ETBinder _ -> assert false (* See check_binder_type *)
-  | ETConstr p | ETConstrAsBinder (_,p) -> ETProdConstr p
+  | ETConstr (s,_,p) -> ETProdConstr (s,p)
   | ETPattern (_,n) -> ETProdPattern (match n with None -> 0 | Some n -> n)
-  | ETOther (s,t) -> ETProdOther (s,t)
 
 let make_production etyps symbols =
   let rec aux = function
@@ -650,9 +658,9 @@ let make_production etyps symbols =
             | Break _ -> []
             | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in
 	match List.assoc x etyps with
-        | ETConstr typ ->
+        | ETConstr (s,_,typ) ->
             let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in
-            expand_list_rule typ tkl x 1 p (aux l')
+            expand_list_rule s typ tkl x 1 p (aux l')
         | ETBinder o ->
             check_open_binder o sl x;
             let typ = if o then (assert (tkl = []); ETBinderOpen) else ETBinderClosed tkl in
@@ -674,8 +682,7 @@ let rec find_symbols c_current c_next c_last = function
       (x,c_next)::(find_symbols c_next c_next c_last sl')
 
 let border = function
-  | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a
-  | (_,(ETConstrAsBinder(_,(_,BorderProd (_,a))))) :: _ -> a
+  | (_,(ETConstr(_,_,(_,BorderProd (_,a))))) :: _ -> a
   | _ -> None
 
 let recompute_assoc typs =
@@ -697,30 +704,31 @@ let pr_arg_level from (lev,typ) =
   | (n,_) -> str "Unknown level" in
   Ppvernac.pr_set_entry_type (fun _ -> (*TO CHECK*) mt()) typ ++
   (match typ with
-   | ETConstr _ | ETConstrAsBinder _ | ETPattern _ -> spc () ++ pplev lev
+   | ETConstr _ | ETPattern _ -> spc () ++ pplev lev
    | _ -> mt ())
 
-let pr_level ntn (from,args,typs) =
-  str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
-  prlist_with_sep pr_comma (pr_arg_level from) (List.combine args typs)
+let pr_level ntn (from,fromlevel,args,typs) =
+  (match from with InConstrEntry -> mt () | InCustomEntry s -> str "in " ++ str s ++ spc()) ++
+  str "at level " ++ int fromlevel ++ spc () ++ str "with arguments" ++ spc() ++
+  prlist_with_sep pr_comma (pr_arg_level fromlevel) (List.combine args typs)
 
 let error_incompatible_level ntn oldprec prec =
   user_err 
-    (str "Notation " ++ qstring ntn ++ str " is already defined" ++ spc() ++
+    (str "Notation " ++ pr_notation 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 ".")
 
 let error_parsing_incompatible_level ntn ntn' oldprec prec =
   user_err
-    (str "Notation " ++ qstring ntn ++ str " relies on a parsing rule for " ++ qstring ntn' ++ spc() ++
+    (str "Notation " ++ pr_notation ntn ++ str " relies on a parsing rule for " ++ pr_notation ntn' ++ spc() ++
     str " which 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_term.level;
+  synext_level : Notation_gram.level;
   synext_notation : notation;
   synext_notgram : notation_grammar;
   synext_unparsing : unparsing list;
@@ -737,10 +745,10 @@ type syntax_extension_obj = locality_flag * syntax_extension
 let check_and_extend_constr_grammar ntn rule =
   try
     let ntn_for_grammar = rule.notgram_notation in
-    if String.equal ntn ntn_for_grammar then raise Not_found;
+    if notation_eq ntn ntn_for_grammar then raise Not_found;
     let prec = rule.notgram_level in
-    let oldprec = Notation.level_of_notation ntn_for_grammar in
-    if not (Notation.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec;
+    let oldprec = Notgram_ops.level_of_notation ntn_for_grammar in
+    if not (Notgram_ops.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec;
   with Not_found ->
     Egramcoq.extend_constr_grammar rule
 
@@ -749,17 +757,17 @@ let cache_one_syntax_extension se =
   let prec = se.synext_level in
   let onlyprint = se.synext_notgram.notgram_onlyprinting in
   try
-    let oldprec = Notation.level_of_notation ~onlyprint ntn in
-    if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec;
+    let oldprec = Notgram_ops.level_of_notation ~onlyprint ntn in
+    if not (Notgram_ops.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 ~onlyprint;
+      Notgram_ops.declare_notation_level ntn prec ~onlyprint;
       (* Declare the parsing rule *)
       if not onlyprint then List.iter (check_and_extend_constr_grammar ntn) se.synext_notgram.notgram_rules;
       (* Declare the notation rule *)
-      Notation.declare_notation_rule ntn
-        ~extra:se.synext_extra (se.synext_unparsing, pi1 prec) se.synext_notgram
+      declare_notation_rule ntn
+        ~extra:se.synext_extra (se.synext_unparsing, let (_,lev,_,_) = prec in lev) se.synext_notgram
     end
 
 let cache_syntax_extension (_, (_, sy)) =
@@ -796,20 +804,24 @@ module NotationMods = struct
 type notation_modifier = {
   assoc         : gram_assoc option;
   level         : int option;
+  custom        : notation_entry;
   etyps         : (Id.t * simple_constr_prod_entry_key) list;
+  subtyps       : (Id.t * production_level) list;
 
   (* common to syn_data below *)
   only_parsing  : bool;
   only_printing : bool;
   compat        : Flags.compat_version option;
-  format        : Misctypes.lstring option;
+  format        : lstring option;
   extra         : (string * string) list;
 }
 
 let default = {
   assoc         = None;
   level         = None;
+  custom        = InConstrEntry;
   etyps         = [];
+  subtyps       = [];
   only_parsing  = false;
   only_printing = false;
   compat        = None;
@@ -820,53 +832,75 @@ let default = {
 end
 
 let interp_modifiers modl = let open NotationMods in
-  let rec interp acc = function
-    | [] -> acc
+  let rec interp subtyps acc = function
+    | [] -> subtyps, acc
     | SetEntryType (s,typ) :: l ->
 	let id = Id.of_string s in
 	if Id.List.mem_assoc id acc.etyps then
 	  user_err ~hdr:"Metasyntax.interp_modifiers"
             (str s ++ str " is already assigned to an entry or constr level.");
-        interp { acc with etyps = (id,typ) :: acc.etyps; } l
-    | SetItemLevel ([],n) :: l ->
-        interp acc l
-    | SetItemLevelAsBinder ([],_,_) :: l ->
-        interp acc l
-    | SetItemLevel (s::idl,n) :: l ->
+        interp subtyps { acc with etyps = (id,typ) :: acc.etyps; } l
+    | SetItemLevel ([],bko,n) :: l ->
+        interp subtyps acc l
+    | SetItemLevel (s::idl,bko,n) :: l ->
 	let id = Id.of_string s in
 	if Id.List.mem_assoc id acc.etyps then
 	  user_err ~hdr:"Metasyntax.interp_modifiers"
             (str s ++ str " is already assigned to an entry or constr level.");
-        let typ = ETConstr (Some n) in
-        interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l)
-    | SetItemLevelAsBinder (s::idl,bk,n) :: l ->
-        let id = Id.of_string s in
-        if Id.List.mem_assoc id acc.etyps then
-          user_err ~hdr:"Metasyntax.interp_modifiers"
-            (str s ++ str " is already assigned to an entry or constr level.");
-        let typ = ETConstrAsBinder (bk,n) in
-        interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevelAsBinder (idl,bk,n)::l)
+        interp ((id,bko,n)::subtyps) acc (SetItemLevel (idl,bko,n)::l)
     | SetLevel n :: l ->
-        interp { acc with level = Some n; } l
+        (match acc.custom with
+        | InCustomEntry s ->
+          if acc.level <> None then
+            user_err (str ("isolated \"at level " ^ string_of_int n ^ "\" unexpected."))
+          else
+            user_err (str ("use \"in custom " ^ s ^ " at level " ^ string_of_int n ^
+                         "\"") ++ spc () ++ str "rather than" ++ spc () ++
+                         str ("\"at level " ^ string_of_int n ^ "\"") ++
+                         spc () ++ str "isolated.")
+        | InConstrEntry ->
+          if acc.level <> None then
+            user_err (str "A level is already assigned.");
+          interp subtyps { acc with level = Some n; } l)
+    | SetCustomEntry (s,n) :: l ->
+        if acc.level <> None then
+          (if n = None then
+            user_err (str ("use \"in custom " ^ s ^ " at level " ^
+                         string_of_int (Option.get acc.level) ^
+                         "\"") ++ spc () ++ str "rather than" ++ spc () ++
+                         str ("\"at level " ^
+                         string_of_int (Option.get acc.level) ^ "\"") ++
+                         spc () ++ str "isolated.")
+          else
+            user_err (str ("isolated \"at level " ^ string_of_int (Option.get acc.level) ^ "\" unexpected.")));
+        if acc.custom <> InConstrEntry then
+           user_err (str "Entry is already assigned to custom " ++ str s ++ (match acc.level with None -> mt () | Some lev -> str " at level " ++ int lev) ++ str ".");
+        interp subtyps { acc with custom = InCustomEntry s; level = n } l
     | SetAssoc a :: l ->
 	if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once.");
-        interp { acc with assoc = Some a; } l
+        interp subtyps { acc with assoc = Some a; } l
      | SetOnlyParsing :: l ->
-        interp { acc with only_parsing = true; } l
+        interp subtyps { acc with only_parsing = true; } l
     | SetOnlyPrinting :: l ->
-        interp { acc with only_printing = true; } l
+        interp subtyps { acc with only_printing = true; } l
     | SetCompatVersion v :: l ->
-        interp { acc with compat = Some v; } l
+        interp subtyps { acc with compat = Some v; } l
     | SetFormat ("text",s) :: l ->
 	if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once.");
-        interp { acc with format = Some s; } l
-    | SetFormat (k,{CAst.v=s}) :: l ->
-        interp { acc with extra = (k,s)::acc.extra; } l
-  in interp default modl
+        interp subtyps { acc with format = Some s; } l
+    | SetFormat (k,s) :: l ->
+        interp subtyps { acc with extra = (k,s.CAst.v)::acc.extra; } l
+  in
+  let subtyps,mods = interp [] default modl in
+  (* interpret item levels wrt to main entry *)
+  let extra_etyps = List.map (fun (id,bko,n) -> (id,ETConstr (mods.custom,bko,n))) subtyps in
+  { mods with etyps = extra_etyps@mods.etyps }
 
 let check_infix_modifiers modifiers =
-  let t = (interp_modifiers modifiers).NotationMods.etyps in
-  if not (List.is_empty t) then
+  let mods = interp_modifiers modifiers in
+  let t = mods.NotationMods.etyps in
+  let u = mods.NotationMods.subtyps in
+  if not (List.is_empty t) || not (List.is_empty u) then
     user_err Pp.(str "Explicit entry level or type unexpected in infix notation.")
 
 let check_useless_entry_types recvars mainvars etyps =
@@ -907,21 +941,18 @@ let get_compat_version mods =
 
 (* Compute precedences from modifiers (or find default ones) *)
 
-let set_entry_type etyps (x,typ) =
+let set_entry_type from etyps (x,typ) =
   let typ = try
     match List.assoc x etyps, typ with
-      | ETConstr (Some n), (_,BorderProd (left,_)) ->
-          ETConstr (n,BorderProd (left,None))
-      | ETConstr (Some n), (_,InternalProd) -> ETConstr (n,InternalProd)
-      | ETConstrAsBinder (bk, Some n), (_,BorderProd (left,_)) ->
-          ETConstrAsBinder (bk, (n,BorderProd (left,None)))
-      | ETConstrAsBinder (bk, Some n), (_,InternalProd) ->
-         ETConstrAsBinder (bk, (n,InternalProd))
+      | ETConstr (s,bko,Some n), (_,BorderProd (left,_)) ->
+          ETConstr (s,bko,(n,BorderProd (left,None)))
+      | ETConstr (s,bko,Some n), (_,InternalProd) ->
+         ETConstr (s,bko,(n,InternalProd))
       | ETPattern (b,n), _ -> ETPattern (b,n)
-      | (ETName | ETBigint | ETReference | ETBinder _ | ETOther _ as x), _ -> x
-      | ETConstr None, _ -> ETConstr typ
-      | ETConstrAsBinder (bk,None), _ -> ETConstrAsBinder (bk,typ)
-    with Not_found -> ETConstr typ
+      | (ETIdent | ETBigint | ETGlobal | ETBinder _ as x), _ -> x
+      | ETConstr (s,bko,None), _ -> ETConstr (s,bko,typ)
+    with Not_found ->
+      ETConstr (from,None,typ)
   in (x,typ)
 
 let join_auxiliary_recursive_types recvars etyps =
@@ -941,8 +972,8 @@ let join_auxiliary_recursive_types recvars etyps =
 
 let internalization_type_of_entry_type = function
   | ETBinder _ -> NtnInternTypeOnlyBinder
-  | ETConstr _ | ETConstrAsBinder _ | ETBigint | ETReference
-  | ETName | ETPattern _ | ETOther _ -> NtnInternTypeAny
+  | ETConstr _ | ETBigint | ETGlobal
+  | ETIdent | ETPattern _ -> NtnInternTypeAny
 
 let set_internalization_type typs =
   List.map (fun (_, e) -> internalization_type_of_entry_type e) typs
@@ -953,20 +984,28 @@ let make_internalization_vars recvars mainvars typs =
   maintyps @ extratyps
 
 let make_interpretation_type isrec isonlybinding = function
-  | ETConstr _ ->
-     if isrec then NtnTypeConstrList else
-     if isonlybinding then
-       (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *)
-       NtnTypeBinder (NtnBinderParsedAsConstr AsIdent)
-     else NtnTypeConstr
-  | ETConstrAsBinder (bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk)
-  | ETName -> NtnTypeBinder NtnParsedAsIdent
+  (* Parsed as constr list *)
+  | ETConstr (_,None,_) when isrec -> NtnTypeConstrList
+  (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *)
+  | ETConstr (_,Some bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk)
+  | ETConstr (_,None,_) when isonlybinding -> NtnTypeBinder (NtnBinderParsedAsConstr AsIdent)
+  (* Parsed as constr, interpreted as constr *)
+  | ETConstr (_,None,_) -> NtnTypeConstr
+  (* Others *)
+  | ETIdent -> NtnTypeBinder NtnParsedAsIdent
   | ETPattern (ppstrict,_) -> NtnTypeBinder (NtnParsedAsPattern ppstrict) (* Parsed as ident/pattern, primarily interpreted as binder; maybe strict at printing *)
-  | ETBigint | ETReference | ETOther _ -> NtnTypeConstr
+  | ETBigint | ETGlobal -> NtnTypeConstr
   | ETBinder _ ->
      if isrec then NtnTypeBinderList
      else anomaly Pp.(str "Type binder is only for use in recursive notations for binders.")
 
+let subentry_of_constr_prod_entry = function
+  | ETConstr (InCustomEntry s,_,(NumLevel n,_)) -> InCustomEntryLevel (s,n)
+  (* level and use of parentheses for coercion is hard-wired for "constr";
+     we don't remember the level *)
+  | ETConstr (InConstrEntry,_,_) -> InConstrEntrySomeLevel
+  | _ -> InConstrEntrySomeLevel
+
 let make_interpretation_vars recvars allvars typs =
   let eq_subscope (sc1, l1) (sc2, l2) =
     Option.equal String.equal sc1 sc2 &&
@@ -982,7 +1021,9 @@ let make_interpretation_vars recvars allvars typs =
   let mainvars =
     Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in
   Id.Map.mapi (fun x (isonlybinding, sc) ->
-    (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding (Id.List.assoc x typs))) mainvars
+    let typ = Id.List.assoc x typs in
+    ((subentry_of_constr_prod_entry 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
@@ -1008,17 +1049,42 @@ let warn_non_reversible_notation =
              str " not occur in the right-hand side." ++ spc() ++
              strbrk "The notation will not be used for printing as it is not reversible.")
 
-let is_not_printable onlyparse reversibility = function
-| NVar _ ->
-  if not onlyparse then warn_notation_bound_to_variable ();
-  true
+let make_custom_entry custom level =
+  match custom with
+  | InConstrEntry -> InConstrEntrySomeLevel
+  | InCustomEntry s -> InCustomEntryLevel (s,level)
+
+type entry_coercion_kind =
+  | IsEntryCoercion of notation_entry_level
+  | IsEntryGlobal of string * int
+  | IsEntryIdent of string * int
+
+let is_coercion = function
+  | Some (custom,n,_,[e]) ->
+     (match e, custom with
+     | ETConstr _, _ ->
+         let customkey = make_custom_entry custom n in
+         let subentry = subentry_of_constr_prod_entry e in
+         if notation_entry_level_eq subentry customkey then None
+         else Some (IsEntryCoercion subentry)
+     | ETGlobal, InCustomEntry s -> Some (IsEntryGlobal (s,n))
+     | ETIdent, InCustomEntry s -> Some (IsEntryIdent (s,n))
+     | _ -> None)
+  | Some _ -> assert false
+  | None -> None
+
+let printability level onlyparse reversibility = function
+| NVar _ when reversibility = APrioriReversible ->
+  let coe = is_coercion level in
+  if not onlyparse && coe = None then
+    warn_notation_bound_to_variable ();
+  true, coe
 | _ ->
-   if not onlyparse && reversibility <> APrioriReversible then
+   (if not onlyparse && reversibility <> APrioriReversible then
      (warn_non_reversible_notation reversibility; true)
-  else onlyparse
+    else onlyparse),None
 
-
-let find_precedence lev etyps symbols onlyprint =
+let find_precedence custom lev etyps symbols onlyprint =
   let first_symbol =
     let rec aux = function
       | Break _ :: t -> aux t
@@ -1042,10 +1108,9 @@ let find_precedence lev etyps symbols onlyprint =
           else [],Option.get lev
         else
           user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") in
-      (try match List.assoc x etyps with
-        | ETConstr _ -> test ()
-        | ETConstrAsBinder (_,Some _) -> test ()
-        | (ETName | ETBigint | ETReference) ->
+      (try match List.assoc x etyps, custom with
+        | ETConstr (s,_,Some _), s' when s = s' -> test ()
+        | (ETIdent | ETBigint | ETGlobal), _ ->
             begin match lev with
             | None ->
 	      ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0)
@@ -1054,7 +1119,7 @@ let find_precedence lev etyps symbols onlyprint =
             | _ ->
               user_err Pp.(str "A notation starting with an atomic expression must be at level 0.")
             end
-        | (ETPattern _ | ETBinder _ | ETOther _ | ETConstrAsBinder _) ->
+        | (ETPattern _ | ETBinder _ | ETConstr _), _ ->
             (* Give a default ? *)
             if Option.is_empty lev then
               user_err Pp.(str "Need an explicit level.")
@@ -1072,7 +1137,7 @@ let find_precedence lev etyps symbols onlyprint =
       [],Option.get lev
 
 let check_curly_brackets_notation_exists () =
-  try let _ = Notation.level_of_notation "{ _ }" in ()
+  try let _ = Notgram_ops.level_of_notation (InConstrEntrySomeLevel,"{ _ }") in ()
   with Not_found ->
     user_err Pp.(str "Notations involving patterns of the form \"{ _ }\" are treated \n\
 specially and require that the notation \"{ _ }\" is already reserved.")
@@ -1102,7 +1167,7 @@ let remove_curly_brackets l =
 
 module SynData = struct
 
-  type subentry_types = (Id.t * (production_level * production_position) constr_entry_key_gen) list
+  type subentry_types = (Id.t * constr_entry_key) list
 
   (* XXX: Document *)
   type syn_data = {
@@ -1114,7 +1179,7 @@ module SynData = struct
     only_parsing  : bool;
     only_printing : bool;
     compat        : Flags.compat_version option;
-    format        : Misctypes.lstring option;
+    format        : lstring option;
     extra         : (string * string) list;
 
     (* XXX: Callback to printing, must remove *)
@@ -1136,7 +1201,7 @@ module SynData = struct
 
 end
 
-let find_subentry_types n assoc etyps symbols =
+let find_subentry_types from n assoc etyps symbols =
   let innerlevel = NumLevel 200 in
   let typs =
     find_symbols
@@ -1144,11 +1209,21 @@ let find_subentry_types n assoc etyps symbols =
       (innerlevel,InternalProd)
       (NumLevel n,BorderProd(Right,assoc))
       symbols in
-  let sy_typs = List.map (set_entry_type etyps) typs in
-  let prec = List.map (assoc_of_type n) sy_typs in
+  let sy_typs = List.map (set_entry_type from etyps) typs in
+  let prec = List.map (assoc_of_type from n) sy_typs in
   sy_typs, prec
 
-let compute_syntax_data df modifiers =
+let check_locality_compatibility local custom i_typs =
+  if not local then
+    let subcustom = List.map_filter (function _,ETConstr (InCustomEntry s,_,_) -> Some s | _ -> None) i_typs in
+    let allcustoms = match custom with InCustomEntry s -> s::subcustom | _ -> subcustom in
+    List.iter (fun s ->
+        if Egramcoq.locality_of_custom_entry s then
+          user_err (strbrk "Notation has to be declared local as it depends on custom entry " ++ str s ++
+                    strbrk " which is local."))
+      (List.uniquize allcustoms)
+
+let compute_syntax_data local df modifiers =
   let open SynData in
   let open NotationMods in
   let mods = interp_modifiers modifiers in
@@ -1161,25 +1236,28 @@ let compute_syntax_data df modifiers =
   let _ = check_binder_type recvars mods.etyps in
 
   (* Notations for interp and grammar  *)
-  let ntn_for_interp = make_notation_key symbols in
-  let symbols_for_grammar = remove_curly_brackets symbols in
+  let msgs,n = find_precedence mods.custom mods.level mods.etyps symbols onlyprint in
+  let custom = make_custom_entry mods.custom n in
+  let ntn_for_interp = make_notation_key custom symbols in
+  let symbols_for_grammar =
+    if custom = InConstrEntrySomeLevel then remove_curly_brackets symbols else symbols in
   let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in
-  let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in
-  if not onlyprint then check_rule_productivity symbols_for_grammar;
-  let msgs,n = find_precedence mods.level mods.etyps symbols onlyprint in
+  let ntn_for_grammar = if need_squash then make_notation_key custom symbols_for_grammar else ntn_for_interp in
+  if mods.custom = InConstrEntry && not onlyprint then check_rule_productivity symbols_for_grammar;
   (* To globalize... *)
   let etyps = join_auxiliary_recursive_types recvars mods.etyps in
   let sy_typs, prec =
-    find_subentry_types n assoc etyps symbols in
+    find_subentry_types mods.custom n assoc etyps symbols in
   let sy_typs_for_grammar, prec_for_grammar =
     if need_squash then
-      find_subentry_types n assoc etyps symbols_for_grammar
+      find_subentry_types mods.custom n assoc etyps symbols_for_grammar
     else
       sy_typs, prec in
   let i_typs = set_internalization_type sy_typs in
+  check_locality_compatibility local mods.custom sy_typs;
   let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in
   let pp_sy_data = (sy_typs,symbols) in
-  let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in
+  let sy_fulldata = (ntn_for_grammar,(mods.custom,n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in
   let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
   let i_data = ntn_for_interp, df' in
 
@@ -1198,15 +1276,15 @@ let compute_syntax_data df modifiers =
     mainvars;
     intern_typs = i_typs;
 
-    level  = (n,prec,List.map snd sy_typs);
+    level  = (mods.custom,n,prec,List.map snd sy_typs);
     pa_syntax_data = pa_sy_data;
     pp_syntax_data = pp_sy_data;
     not_data    = sy_fulldata;
   }
 
-let compute_pure_syntax_data df mods =
+let compute_pure_syntax_data local df mods =
   let open SynData in
-  let sd = compute_syntax_data df mods in
+  let sd = compute_syntax_data local df mods in
   let msgs =
     if sd.only_parsing then
       (Feedback.msg_warning ?loc:None,
@@ -1221,6 +1299,7 @@ type notation_obj = {
   notobj_local : bool;
   notobj_scope : scope_name option;
   notobj_interp : interpretation;
+  notobj_coercion : entry_coercion_kind option;
   notobj_onlyparse : bool;
   notobj_onlyprint : bool;
   notobj_compat : Flags.compat_version option;
@@ -1242,7 +1321,13 @@ let open_notation i (_, nobj) =
     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
+      Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat;
+    (* Declare a possible coercion *)
+    (match nobj.notobj_coercion with
+    | Some (IsEntryCoercion entry) -> Notation.declare_entry_coercion ntn entry
+    | Some (IsEntryGlobal (entry,n)) -> Notation.declare_custom_entry_has_global entry n
+    | Some (IsEntryIdent (entry,n)) -> Notation.declare_custom_entry_has_ident entry n
+    | None -> ())
   end
 
 let cache_notation o =
@@ -1285,10 +1370,10 @@ exception NoSyntaxRule
 
 let recover_notation_syntax ntn =
   try
-    let prec = Notation.level_of_notation ~onlyprint:true ntn (* Be as little restrictive as possible *) 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
+    let prec = Notgram_ops.level_of_notation ~onlyprint:true ntn (* Be as little restrictive as possible *) in
+    let pp_rule,_ = find_notation_printing_rule ntn in
+    let pp_extra_rules = find_notation_extra_printing_rules ntn in
+    let pa_rule = find_notation_parsing_rules ntn in
     { synext_level = prec;
       synext_notation = ntn;
       synext_notgram = pa_rule;
@@ -1300,7 +1385,7 @@ let recover_notation_syntax ntn =
     raise NoSyntaxRule
 
 let recover_squash_syntax sy =
-  let sq = recover_notation_syntax "{ _ }" in
+  let sq = recover_notation_syntax (InConstrEntrySomeLevel,"{ _ }") in
   sy :: sq.synext_notgram.notgram_rules
 
 (**********************************************************************)
@@ -1335,8 +1420,9 @@ let make_pp_rule level (typs,symbols) fmt =
 (* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *)
 let make_syntax_rules (sd : SynData.syn_data) = let open SynData in
   let ntn_for_grammar, prec_for_grammar, need_squash = sd.not_data in
+  let custom,level,_,_ = sd.level in
   let pa_rule = make_pa_rule prec_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash in
-  let pp_rule = make_pp_rule (pi1 sd.level) sd.pp_syntax_data sd.format in {
+  let pp_rule = make_pp_rule (custom,level) sd.pp_syntax_data sd.format in {
     synext_level    = sd.level;
     synext_notation = fst sd.info;
     synext_notgram  = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule };
@@ -1354,7 +1440,7 @@ let to_map l =
 
 let add_notation_in_scope local df env c mods scope =
   let open SynData in
-  let sd = compute_syntax_data df mods in
+  let sd = compute_syntax_data local df mods in
   (* Prepare the interpretation *)
   (* Prepare the parsing and printing rules *)
   let sy_rules = make_syntax_rules sd in
@@ -1366,13 +1452,14 @@ let add_notation_in_scope local df env c mods scope =
   let (acvars, ac, reversibility) = interp_notation_constr env nenv c in
   let interp = make_interpretation_vars sd.recvars acvars (fst sd.pa_syntax_data) in
   let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
-  let onlyparse = is_not_printable sd.only_parsing reversibility ac in
+  let onlyparse,coe = printability (Some sd.level) sd.only_parsing reversibility 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_coercion = coe;
     notobj_onlyprint = sd.only_printing;
     notobj_compat = sd.compat;
     notobj_notation = sd.info;
@@ -1386,16 +1473,17 @@ let add_notation_in_scope local df env c mods scope =
 let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
   let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df 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 sy = recover_notation_syntax (make_notation_key symbs) in
+  let level, i_typs, onlyprint = if not (is_numeral symbs) then begin
+    let sy = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in
     let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in
     (** If the only printing flag has been explicitly requested, put it back *)
     let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in
-    pi3 sy.synext_level, onlyprint
-  end else [], false in
+    let _,_,_,typs = sy.synext_level in
+    Some sy.synext_level, typs, onlyprint
+  end else None, [], false in
   (* Declare interpretation *)
   let path = (Lib.library_dp(), Lib.current_dirpath true) in
-  let df'  = (make_notation_key symbs, (path,df)) in
+  let df'  = (make_notation_key InConstrEntrySomeLevel symbs, (path,df)) in
   let i_vars = make_internalization_vars recvars mainvars (List.map internalization_type_of_entry_type i_typs) in
   let nenv = {
     ninterp_var_type = to_map i_vars;
@@ -1404,13 +1492,14 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_
   let (acvars, ac, reversibility) = interp_notation_constr env ~impls nenv c in
   let interp = make_interpretation_vars recvars acvars (List.combine mainvars i_typs) in
   let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
-  let onlyparse = is_not_printable onlyparse reversibility ac in
+  let onlyparse,coe = printability level onlyparse reversibility 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_coercion = coe;
     notobj_onlyprint = onlyprint;
     notobj_compat = compat;
     notobj_notation = df';
@@ -1421,7 +1510,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_
 (* Notations without interpretation (Reserved Notation) *)
 
 let add_syntax_extension local ({CAst.loc;v=df},mods) = let open SynData in
-  let psd = compute_pure_syntax_data df mods in
+  let psd = compute_pure_syntax_data local df mods in
   let sy_rules = make_syntax_rules {psd with compat = None} in
   Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs;
   Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
@@ -1461,12 +1550,12 @@ let add_notation local env c ({CAst.loc;v=df},modifiers) sc =
 let add_notation_extra_printing_rule df k v =
   let notk = 
     let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in
-    make_notation_key symbs in
-  Notation.add_notation_extra_printing_rule notk k v
+    make_notation_key InConstrEntrySomeLevel symbs in
+  add_notation_extra_printing_rule notk k v
 
 (* Infix notations *)
 
-let inject_var x = CAst.make @@ CRef (CAst.make @@ Ident (Id.of_string x),None)
+let inject_var x = CAst.make @@ CRef (qualid_of_ident (Id.of_string x),None)
 
 let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc =
   check_infix_modifiers modifiers;
@@ -1545,7 +1634,35 @@ let add_syntactic_definition env ident (vars,c) local onlyparse =
       List.map map vars, reversibility, pat
   in
   let onlyparse = match onlyparse with
-    | None when (is_not_printable false reversibility pat) -> Some Flags.Current
+    | None when fst (printability None false reversibility pat) -> Some Flags.Current
     | p -> p
   in
   Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
+
+(**********************************************************************)
+(* Declaration of custom entry                                        *)
+
+let load_custom_entry _ _ = ()
+
+let open_custom_entry _ (_,(local,s)) =
+  Egramcoq.create_custom_entry ~local s
+
+let cache_custom_entry o =
+  load_custom_entry 1 o;
+  open_custom_entry 1 o
+
+let subst_custom_entry (subst,x) = x
+
+let classify_custom_entry (local,s as o) =
+  if local then Dispose else Substitute o
+
+let inCustomEntry : locality_flag * string -> obj =
+  declare_object {(default_object "CUSTOM-ENTRIES") with
+      cache_function = cache_custom_entry;
+      open_function = open_custom_entry;
+      load_function = load_custom_entry;
+      subst_function = subst_custom_entry;
+      classify_function = classify_custom_entry}
+
+let declare_custom_entry local s =
+  Lib.add_anonymous_leaf (inCustomEntry (local,s))
diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli
index a6c12e08..73bee712 100644
--- a/vernac/metasyntax.mli
+++ b/vernac/metasyntax.mli
@@ -14,7 +14,6 @@ open Notation
 open Constrexpr
 open Notation_term
 open Environ
-open Misctypes
 
 val add_token_obj : string -> unit
 
@@ -61,3 +60,5 @@ val pr_grammar : string -> Pp.t
 val check_infix_modifiers : syntax_modifier list -> unit
 
 val with_syntax_protection : ('a -> 'b) -> 'a -> 'b
+
+val declare_custom_entry : locality_flag -> string -> unit
diff --git a/vernac/misctypes.ml b/vernac/misctypes.ml
new file mode 100644
index 00000000..ef9cd3c3
--- /dev/null
+++ b/vernac/misctypes.ml
@@ -0,0 +1,75 @@
+(* Compat module, to be removed in 8.10 *)
+open Names
+
+type lident = Names.lident
+[@@ocaml.deprecated "use [Names.lident"]
+type lname = Names.lname
+[@@ocaml.deprecated "use [Names.lname]"]
+type lstring = Names.lstring
+[@@ocaml.deprecated "use [Names.lstring]"]
+
+type 'a or_by_notation_r = 'a Constrexpr.or_by_notation_r =
+  | AN of 'a [@ocaml.deprecated "use version in [Constrexpr]"]
+  | ByNotation of (string * string option) [@ocaml.deprecated "use version in [Constrexpr]"]
+[@@ocaml.deprecated "use [Constrexpr.or_by_notation_r]"]
+
+type 'a or_by_notation = 'a Constrexpr.or_by_notation
+[@@ocaml.deprecated "use [Constrexpr.or_by_notation]"]
+
+type intro_pattern_naming_expr = Namegen.intro_pattern_naming_expr =
+  | IntroIdentifier of Id.t [@ocaml.deprecated "Use version in [Namegen]"]
+  | IntroFresh of Id.t [@ocaml.deprecated "Use version in [Namegen]"]
+  | IntroAnonymous [@ocaml.deprecated "Use version in [Namegen]"]
+[@@ocaml.deprecated "use [Namegen.intro_pattern_naming_expr]"]
+
+type 'a or_var = 'a Locus.or_var =
+  | ArgArg of 'a [@ocaml.deprecated "Use version in [Locus]"]
+  | ArgVar of Names.lident [@ocaml.deprecated "Use version in [Locus]"]
+[@@ocaml.deprecated "use [Locus.or_var]"]
+
+type quantified_hypothesis = Tactypes.quantified_hypothesis =
+    AnonHyp of int [@ocaml.deprecated "Use version in [Tactypes]"]
+  | NamedHyp of Id.t [@ocaml.deprecated "Use version in [Tactypes]"]
+[@@ocaml.deprecated "use [Tactypes.quantified_hypothesis]"]
+
+type multi = Equality.multi =
+  | Precisely of int [@ocaml.deprecated "use version in [Equality]"]
+  | UpTo of int [@ocaml.deprecated "use version in [Equality]"]
+  | RepeatStar [@ocaml.deprecated "use version in [Equality]"]
+  | RepeatPlus [@ocaml.deprecated "use version in [Equality]"]
+[@@ocaml.deprecated "use [Equality.multi]"]
+
+type 'a bindings = 'a Tactypes.bindings =
+  | ImplicitBindings of 'a list [@ocaml.deprecated "use version in [Tactypes]"]
+  | ExplicitBindings of 'a Tactypes.explicit_bindings [@ocaml.deprecated "use version in [Tactypes]"]
+  | NoBindings [@ocaml.deprecated "use version in [Tactypes]"]
+[@@ocaml.deprecated "use [Tactypes.bindings]"]
+
+type 'constr intro_pattern_expr = 'constr Tactypes.intro_pattern_expr =
+  | IntroForthcoming of bool [@ocaml.deprecated "use version in [Tactypes]"]
+  | IntroNaming of Namegen.intro_pattern_naming_expr [@ocaml.deprecated "use version in [Tactypes]"]
+  | IntroAction of 'constr Tactypes.intro_pattern_action_expr [@ocaml.deprecated "use version in [Tactypes]"]
+and 'constr intro_pattern_action_expr = 'constr Tactypes.intro_pattern_action_expr =
+  | IntroWildcard [@ocaml.deprecated "use [Tactypes]"]
+  | IntroOrAndPattern of 'constr Tactypes.or_and_intro_pattern_expr [@ocaml.deprecated "use [Tactypes]"]
+  | IntroInjection of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"]
+  | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t [@ocaml.deprecated "use [Tactypes]"]
+  | IntroRewrite of bool [@ocaml.deprecated "use [Tactypes]"]
+and 'constr or_and_intro_pattern_expr = 'constr Tactypes.or_and_intro_pattern_expr =
+  | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list [@ocaml.deprecated "use [Tactypes]"]
+  | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"]
+[@@ocaml.deprecated "use version in [Tactypes]"]
+
+type 'id move_location = 'id Logic.move_location =
+  | MoveAfter of 'id [@ocaml.deprecated "use version in [Logic]"]
+  | MoveBefore of 'id [@ocaml.deprecated "use version in [Logic]"]
+  | MoveFirst [@ocaml.deprecated "use version in [Logic]"]
+  | MoveLast [@ocaml.deprecated "use version in [Logic]"]
+[@@ocaml.deprecated "use version in [Logic]"]
+
+type 'a cast_type = 'a Glob_term.cast_type =
+  | CastConv of 'a [@ocaml.deprecated "use version in [Glob_term]"]
+  | CastVM of 'a [@ocaml.deprecated "use version in [Glob_term]"]
+  | CastCoerce [@ocaml.deprecated "use version in [Glob_term]"]
+  | CastNative of 'a [@ocaml.deprecated "use version in [Glob_term]"]
+[@@ocaml.deprecated "use version in [Glob_term]"]
diff --git a/vernac/mltop.ml b/vernac/mltop.ml
index 343b0925..d25dea14 100644
--- a/vernac/mltop.ml
+++ b/vernac/mltop.ml
@@ -345,13 +345,6 @@ let load_ml_object mname ?path fname=
 
 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 *)
 
@@ -396,8 +389,6 @@ let trigger_ml_object verb cache reinit ?path name =
     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
diff --git a/vernac/mltop.mli b/vernac/mltop.mli
index da195f4f..ed1f9a12 100644
--- a/vernac/mltop.mli
+++ b/vernac/mltop.mli
@@ -68,9 +68,6 @@ val add_coq_path : coq_path -> 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} *)
 
diff --git a/vernac/obligations.ml b/vernac/obligations.ml
index 765d6851..2f7dee9a 100644
--- a/vernac/obligations.ml
+++ b/vernac/obligations.ml
@@ -40,7 +40,7 @@ let check_evars env evm =
 
 type oblinfo =
   { ev_name: int * Id.t;
-    ev_hyps: Context.Named.t;
+    ev_hyps: Constr.named_context;
     ev_status: bool * Evar_kinds.obligation_definition_status;
     ev_chop: int option;
     ev_src: Evar_kinds.t Loc.located;
@@ -209,8 +209,10 @@ let eterm_obligations env name evm fs ?status t ty =
     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 hyps = trunc_named_context nc_len hyps in
+         let hyps = EConstr.Unsafe.to_named_context hyps in
+         let concl = EConstr.Unsafe.to_constr ev.evar_concl in
+         let evtyp, deps, transp = etype_of_evar l hyps concl in
 	 let evtyp, hyps, chop =
 	   match chop_product fs evtyp with
 	   | Some t -> t, trunc_named_context fs hyps, fs
@@ -218,7 +220,7 @@ let eterm_obligations env name evm fs ?status t ty =
 	 in
 	 let loc, k = evar_source id evm in
 	 let status = match k with
-           | Evar_kinds.QuestionMark (o,_) -> o
+           | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o
            | _ -> match status with
                  | Some o -> o
                  | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ()))
@@ -257,14 +259,16 @@ let eterm_obligations env name evm fs ?status t ty =
 let tactics_module = ["Program";"Tactics"]
 let safe_init_constant md name () =
   Coqlib.check_required_library ("Coq"::md);
-  Universes.constr_of_global (Coqlib.coq_reference "Obligations" md name)
+  UnivGen.constr_of_global (Coqlib.coq_reference "Obligations" md name)
 let hide_obligation = safe_init_constant tactics_module "obligation"
 
 let pperror cmd = CErrors.user_err ~hdr:"Program" cmd
 let error s = pperror (str s)
 
 let reduce c =
-  EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty (EConstr.of_constr c))
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota env sigma (EConstr.of_constr c))
 
 exception NoObligations of Id.t option
 
@@ -294,17 +298,17 @@ type obligation =
 type obligations = (obligation array * int)
 
 type fixpoint_kind =
-  | IsFixpoint of (Misctypes.lident option * Constrexpr.recursion_order_expr) list
+  | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list
   | IsCoFixpoint
 
-type notations = (Misctypes.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
+type notations = (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:  UState.t;
-  prg_univdecl: Univdecls.universe_decl;
+  prg_univdecl: UState.universe_decl;
   prg_obligations: obligations;
   prg_deps : Id.t list;
   prg_fixkind : fixpoint_kind option ;
@@ -338,7 +342,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optdepr  = false;
-      optname  = "Hidding of Program obligations";
+      optname  = "Hiding of Program obligations";
       optkey   = ["Hide";"Obligations"];
       optread  = get_hide_obligations;
       optwrite = set_hide_obligations; }
@@ -356,7 +360,7 @@ let _ =
       optread  = get_shrink_obligations;
       optwrite = set_shrink_obligations; }
 
-let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
+let evar_of_obligation o = make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type)
 
 let get_obligation_body expand obl =
   match obl.obl_body with
@@ -470,16 +474,15 @@ let subst_body expand 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)
+  let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None)
     (UState.subst prg.prg_ctx) in
   let opaque = prg.prg_opaque in
   let fix_exn = Hook.get get_fix_exn () in
   let typ = nf typ in
   let body = nf body in
-  let env = Global.env () in
   let uvars = Univ.LSet.union
-      (Univops.universes_of_constr env typ)
-      (Univops.universes_of_constr env body) in
+      (Univops.universes_of_constr typ)
+      (Univops.universes_of_constr body) in
   let uctx = UState.restrict prg.prg_ctx uvars in
   let univs = UState.check_univ_decl ~poly:(pi2 prg.prg_kind) uctx prg.prg_univdecl in
   let ce = definition_entry ~fix_exn ~opaque ~types:typ ~univs body in
@@ -555,7 +558,7 @@ let declare_mutual_definition l =
   (* Declare the recursive definitions *)
   let univs = UState.const_univ_entry ~poly first.prg_ctx in
   let fix_exn = Hook.get get_fix_exn () in
-  let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) Universes.empty_binders univs)
+  let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs)
     fixnames fixdecls fixtypes fiximps in
     (* Declare notations *)
     List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations;
@@ -611,7 +614,7 @@ let shrink_body c ty =
 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)
+  Hints.add_hints ~local [Id.to_string prg.prg_name] (unfold_entry cst)
 
 let it_mkLambda_or_LetIn_or_clean t ctx =
   let open Context.Rel.Declaration in
@@ -743,7 +746,7 @@ let all_programs () =
 type progress =
     | Remain of int
     | Dependent
-    | Defined of global_reference
+    | Defined of GlobRef.t
 
 let obligations_message rem =
   if rem > 0 then
@@ -814,10 +817,9 @@ let rec string_of_list sep f = function
 
 let solve_by_tac name evi t poly ctx =
   let id = name in
-  let concl = EConstr.of_constr 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
+    id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_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, () = Future.force entry.const_entry_body in
@@ -849,12 +851,12 @@ let obligation_terminator name num guard hook auto pf =
     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.Expand), Opaque -> err_not_transp ()
+      | (true, _), Opaque -> err_not_transp ()
+      | (false, _), Opaque -> Evar_kinds.Define true
+      | (_, Evar_kinds.Define true), Transparent ->
         Evar_kinds.Define false
-      | (_, status), Vernacexpr.Transparent -> status
+      | (_, status), Transparent -> status
     in
     let obl = { obl with obl_status = false, status } in
     let ctx =
@@ -893,7 +895,7 @@ let obligation_terminator name num guard hook auto pf =
 
 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 cst = match gr with GlobRef.ConstRef cst -> cst | _ -> assert false in
   let transparent = evaluable_constant cst (Global.env ()) in
   let () = match obl.obl_status with
       (true, Evar_kinds.Expand) 
@@ -1071,9 +1073,11 @@ let show_obligations_of_prg ?(msg=true) prg =
 		       if !showed > 0 then (
 		         decr showed;
 			 let x = subst_deps_obl obls x in
+                         let env = Global.env () in
+                         let sigma = Evd.from_env env 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 ++
+                                   hov 1 (Printer.pr_constr_env env sigma x.obl_type ++
 					    str "." ++ fnl ())))
 		   | Some _ -> ())
       obls
@@ -1089,11 +1093,13 @@ let show_obligations ?(msg=true) n =
 let show_term n =
   let prg = get_prog_err n in
   let n = prg.prg_name in
+  let env = Global.env () in
+  let sigma = Evd.from_env env 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)
+             Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
+            ++ Printer.pr_constr_env env sigma prg.prg_body)
 
-let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl)
+let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl)
                    ?(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
@@ -1113,7 +1119,7 @@ let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl)
 	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
 	| _ -> res)
 
-let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic
+let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?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
diff --git a/vernac/obligations.mli b/vernac/obligations.mli
index cc2cacd8..a37c30aa 100644
--- a/vernac/obligations.mli
+++ b/vernac/obligations.mli
@@ -12,7 +12,6 @@ open Environ
 open Constr
 open Evd
 open Names
-open Globnames
 
 (* This is a hack to make it possible for Obligations to craft a Qed
  * behind the scenes.  The fix_exn the Stm attaches to the Future proof
@@ -49,13 +48,13 @@ type obligation_info =
 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 *)
+  | Defined of GlobRef.t (* Defined as id *)
 
 val default_tactic : unit Proofview.tactic ref
 
 val add_definition : Names.Id.t -> ?term:constr -> types -> 
   UState.t ->
-  ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *)
+  ?univdecl:UState.universe_decl -> (* Universe binders and constraints *)
   ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
   ?kind:Decl_kinds.definition_kind ->
   ?tactic:unit Proofview.tactic ->
@@ -63,17 +62,17 @@ val add_definition : Names.Id.t -> ?term:constr -> types ->
   ?hook:(UState.t -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress
 
 type notations =
-    (Misctypes.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
+    (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
 
 type fixpoint_kind =
-  | IsFixpoint of (Misctypes.lident option * Constrexpr.recursion_order_expr) list
+  | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list
   | IsCoFixpoint
 
 val add_mutual_definitions :
   (Names.Id.t * constr * types *
       (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
   UState.t ->
-  ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *)
+  ?univdecl:UState.universe_decl -> (* Universe binders and constraints *)
   ?tactic:unit Proofview.tactic ->
   ?kind:Decl_kinds.definition_kind ->
   ?reduce:(constr -> constr) ->
diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml
new file mode 100644
index 00000000..ecebcf52
--- /dev/null
+++ b/vernac/ppvernac.ml
@@ -0,0 +1,1231 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Pp
+open Names
+
+open CErrors
+open Util
+open CAst
+
+open Extend
+open Decl_kinds
+open Constrexpr
+open Constrexpr_ops
+open Vernacexpr
+open Declaremods
+open Pputils
+
+  open Ppconstr
+
+  let do_not_tag _ x = x
+  let tag_keyword = do_not_tag ()
+  let tag_vernac  = do_not_tag
+
+  let keyword s = tag_keyword (str s)
+
+  let pr_constr = pr_constr_expr
+  let pr_lconstr = pr_lconstr_expr
+  let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
+
+  let pr_uconstraint (l, d, r) =
+    pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++
+      pr_glob_level r
+
+  let pr_univ_name_list = function
+    | None -> mt ()
+    | Some l ->
+      str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}"
+
+  let pr_univdecl_instance l extensible =
+    prlist_with_sep spc pr_lident l ++
+    (if extensible then str"+" else mt ())
+
+  let pr_univdecl_constraints l extensible =
+    if List.is_empty l && extensible then mt ()
+    else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++
+           (if extensible then str"+" else mt())
+
+  let pr_universe_decl l =
+    let open UState in
+    match l with
+    | None -> mt ()
+    | Some l ->
+      str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++
+        pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}"
+
+  let pr_ident_decl (lid, l) =
+    pr_lident lid ++ pr_universe_decl l
+
+  let string_of_fqid fqid =
+    String.concat "." (List.map Id.to_string fqid)
+
+  let pr_fqid fqid = str (string_of_fqid fqid)
+
+  let pr_lfqid {CAst.loc;v=fqid} =
+    match loc with
+    | None     -> pr_fqid fqid
+    | Some loc -> let (b,_) = Loc.unloc loc in
+                  pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid
+
+  let pr_lname_decl (n, u) =
+    pr_lname n ++ pr_universe_decl u
+
+  let pr_smart_global = Pputils.pr_or_by_notation pr_qualid
+
+  let pr_ltac_ref = Libnames.pr_qualid
+
+  let pr_module = Libnames.pr_qualid
+
+  let pr_import_module = Libnames.pr_qualid
+
+  let sep_end = function
+    | VernacBullet _
+    | VernacSubproof _
+    | VernacEndSubproof -> str""
+    | _ -> str"."
+
+  let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t
+
+  let sep = fun _ -> spc()
+  let sep_v2 = fun _ -> str"," ++ spc()
+
+  let pr_notation_entry = function
+    | InConstrEntry -> keyword "constr"
+    | InCustomEntry s -> keyword "custom" ++ spc () ++ str s
+
+  let pr_at_level = function
+    | NumLevel n -> keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n
+    | NextLevel -> keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level"
+
+  let pr_constr_as_binder_kind = let open Notation_term in function
+    | AsIdent -> spc () ++ keyword "as ident"
+    | AsIdentOrPattern -> spc () ++ keyword "as pattern"
+    | AsStrictPattern -> spc () ++ keyword "as strict pattern"
+
+  let pr_strict b = if b then str "strict " else mt ()
+
+  let pr_set_entry_type pr = function
+    | ETIdent -> str"ident"
+    | ETGlobal -> str"global"
+    | ETPattern (b,None) -> pr_strict b ++ str"pattern"
+    | ETPattern (b,Some n) -> pr_strict b ++ str"pattern" ++ spc () ++ pr_at_level (NumLevel n)
+    | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko
+    | ETBigint -> str "bigint"
+    | ETBinder true -> str "binder"
+    | ETBinder false -> str "closed binder"
+
+  let pr_at_level_opt = function
+    | None -> mt ()
+    | Some n -> spc () ++ pr_at_level n
+
+  let pr_set_simple_entry_type =
+    pr_set_entry_type pr_at_level_opt
+
+  let pr_comment pr_c = function
+    | CommentConstr c -> pr_c c
+    | CommentString s -> qs s
+    | CommentInt n -> int n
+
+  let pr_in_out_modules = function
+    | SearchInside l -> spc() ++ keyword "inside" ++ spc() ++ prlist_with_sep sep pr_module l
+    | SearchOutside [] -> mt()
+    | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l
+
+  let pr_search_about (b,c) =
+    (if b then str "-" else mt()) ++
+      match c with
+        | SearchSubPattern p -> pr_constr_pattern_expr p
+        | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
+
+  let pr_search a gopt b pr_p =
+    pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt
+    ++
+      match a with
+      | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchAbout sl ->
+         keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b
+
+  let pr_option_ref_value = function
+    | QualidRefValue id -> pr_qualid id
+    | StringRefValue s -> qs s
+
+  let pr_printoption table b =
+    prlist_with_sep spc str table ++
+      pr_opt (prlist_with_sep sep pr_option_ref_value) b
+
+  let pr_set_option a b =
+    let pr_opt_value = function
+      | IntValue None -> assert false
+    (* This should not happen because of the grammar *)
+      | IntValue (Some n) -> spc() ++ int n
+      | StringValue s -> spc() ++ str s
+      | StringOptValue None -> mt()
+      | StringOptValue (Some s) -> spc() ++ str s
+      | BoolValue b -> mt()
+    in pr_printoption a None ++ pr_opt_value b
+
+  let pr_opt_hintbases l = match l with
+    | [] -> mt()
+    | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
+
+  let pr_reference_or_constr pr_c = let open Hints in function
+    | HintsReference r -> pr_qualid r
+    | HintsConstr c -> pr_c c
+
+  let pr_hint_mode = let open Hints in function
+    | ModeInput -> str"+"
+    | ModeNoHeadEvar -> str"!"
+    | ModeOutput -> str"-"
+
+  let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } =
+    pr_opt (fun x -> str"|" ++ int x) pri ++
+    pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat
+
+  let pr_hints db h pr_c pr_pat =
+    let opth = pr_opt_hintbases db  in
+    let pph =
+      let open Hints in
+      match h with
+        | HintsResolve l ->
+          keyword "Resolve " ++ prlist_with_sep sep
+            (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info)
+            l
+        | HintsResolveIFF (l2r, l, n) ->
+          keyword "Resolve " ++ str (if l2r then "->" else "<-")
+          ++ prlist_with_sep sep pr_qualid l
+        | HintsImmediate l ->
+          keyword "Immediate" ++ spc() ++
+            prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l
+        | HintsUnfold l ->
+          keyword "Unfold" ++ spc () ++ prlist_with_sep sep pr_qualid l
+        | HintsTransparency (l, b) ->
+          keyword (if b then "Transparent" else "Opaque")
+          ++ spc ()
+          ++ (match l with
+              | HintsVariables -> keyword "Variables"
+              | HintsConstants -> keyword "Constants"
+              | HintsReferences l -> prlist_with_sep sep pr_qualid l)
+        | HintsMode (m, l) ->
+          keyword "Mode"
+          ++ spc ()
+          ++ pr_qualid m ++ spc() ++
+            prlist_with_sep spc pr_hint_mode l
+        | HintsConstructors c ->
+          keyword "Constructors"
+          ++ spc() ++ prlist_with_sep spc pr_qualid c
+        | HintsExtern (n,c,tac) ->
+          let pat = match c with None -> mt () | Some pat -> pr_pat pat in
+          keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
+            spc() ++ Pputils.pr_raw_generic (Global.env ()) tac
+    in
+    hov 2 (keyword "Hint "++ pph ++ opth)
+
+  let pr_with_declaration pr_c = function
+    | CWith_Definition (id,udecl,c) ->
+      let p = pr_c c in
+      keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p
+    | CWith_Module (id,qid) ->
+      keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
+        pr_qualid qid
+
+  let rec pr_module_ast leading_space pr_c = function
+    | { loc ; v = CMident qid } ->
+      if leading_space then
+        spc () ++ pr_located pr_qualid (loc, qid)
+      else
+        pr_located pr_qualid (loc,qid)
+    | { v = CMwith (mty,decl) } ->
+      let m = pr_module_ast leading_space pr_c mty in
+      let p = pr_with_declaration pr_c decl in
+      m ++ spc() ++ keyword "with" ++ spc() ++ p
+    | { v = CMapply (me1, ( { v = CMident _ } as me2 ) ) } ->
+      pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2
+    | { v = CMapply (me1,me2) } ->
+      pr_module_ast leading_space pr_c me1 ++ spc() ++
+        hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")")
+
+  let pr_inline = function
+    | DefaultInline -> mt ()
+    | NoInline -> str "[no inline]"
+    | InlineAt i -> str "[inline at level " ++ int i ++ str "]"
+
+  let pr_assumption_inline = function
+    | DefaultInline -> str "Inline"
+    | NoInline -> mt ()
+    | InlineAt i -> str "Inline(" ++ int i ++ str ")"
+
+  let pr_module_ast_inl leading_space pr_c (mast,inl) =
+    pr_module_ast leading_space pr_c mast ++ pr_inline inl
+
+  let pr_of_module_type prc = function
+    | Enforce mty -> str ":" ++ pr_module_ast_inl true prc mty
+    | Check mtys ->
+      prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl true prc m) mtys
+
+  let pr_require_token = function
+    | Some true ->
+      keyword "Export" ++ spc ()
+    | Some false ->
+      keyword "Import" ++ spc ()
+    | None -> mt()
+
+  let pr_module_vardecls pr_c (export,idl,(mty,inl)) =
+    let m = pr_module_ast true pr_c mty in
+    spc() ++
+      hov 1 (str"(" ++ pr_require_token export ++
+               prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
+
+  let pr_module_binders l pr_c =
+    prlist_strict (pr_module_vardecls pr_c) l
+
+  let pr_type_option pr_c = function
+    | { v = CHole (k, Namegen.IntroAnonymous, _) } -> mt()
+    | _ as c -> brk(0,2) ++ str" :" ++ pr_c c
+
+  let pr_decl_notation prc ({loc; v=ntn},c,scopt) =
+    fnl () ++ keyword "where " ++ qs ntn ++ str " := "
+    ++ Flags.without_option Flags.beautify prc c ++
+      pr_opt (fun sc -> str ": " ++ str sc) scopt
+
+  let pr_binders_arg =
+    pr_non_empty_arg pr_binders
+
+  let pr_and_type_binders_arg bl =
+    pr_binders_arg bl
+
+  let pr_onescheme (idop,schem) =
+    match schem with
+      | InductionScheme (dep,ind,s) ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc ()
+        ) ++
+          hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for")
+                 ++ spc() ++ pr_smart_global ind) ++ spc() ++
+          hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s)
+      | CaseScheme (dep,ind,s) ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc ()
+        ) ++
+          hov 0 ((if dep then keyword "Elimination for" else keyword "Case for")
+                 ++ spc() ++ pr_smart_global ind) ++ spc() ++
+          hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s)
+      | EqualityScheme ind ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc()
+        ) ++
+          hov 0 (keyword "Equality for")
+        ++ spc() ++ pr_smart_global ind
+
+  let begin_of_inductive = function
+    | [] -> 0
+    | (_,({loc},_))::_ -> Option.cata (fun loc -> fst (Loc.unloc loc)) 0 loc
+
+  let pr_class_rawexpr = function
+    | FunClass -> keyword "Funclass"
+    | SortClass -> keyword "Sortclass"
+    | RefClass qid -> pr_smart_global qid
+
+  let pr_assumption_token many discharge kind =
+    match discharge, kind with
+      | (NoDischarge,Logical) ->
+        keyword (if many then "Axioms" else "Axiom")
+      | (NoDischarge,Definitional) ->
+        keyword (if many then "Parameters" else "Parameter")
+      | (NoDischarge,Conjectural) -> str"Conjecture"
+      | (DoDischarge,Logical) ->
+        keyword (if many then "Hypotheses" else "Hypothesis")
+      | (DoDischarge,Definitional) ->
+        keyword (if many then "Variables" else "Variable")
+      | (DoDischarge,Conjectural) ->
+        anomaly (Pp.str "Don't know how to beautify a local conjecture.")
+
+  let pr_params pr_c (xl,(c,t)) =
+    hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
+             (if c then str":>" else str":" ++
+                 spc() ++ pr_c t))
+
+  let rec factorize = function
+    | [] -> []
+    | (c,(idl,t))::l ->
+      match factorize l with
+        | (xl,((c', t') as r))::l'
+            when (c : bool) == c' && Pervasives.(=) t t' ->
+          (** FIXME: we need equality on constr_expr *)
+          (idl@xl,r)::l'
+        | l' -> (idl,(c,t))::l'
+
+  let pr_ne_params_list pr_c l =
+    match factorize l with
+      | [p] -> pr_params pr_c p
+      | l ->
+        prlist_with_sep spc
+          (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l
+
+(*
+  prlist_with_sep pr_semicolon (pr_params pr_c)
+*)
+
+  let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k)
+
+  let pr_syntax_modifier = function
+    | SetItemLevel (l,bko,n) ->
+      prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level_opt n ++
+      pr_opt pr_constr_as_binder_kind bko
+    | SetLevel n -> pr_at_level (NumLevel n)
+    | SetCustomEntry (s,n) -> keyword "in" ++ spc() ++ keyword "custom" ++ spc() ++ str s ++ (match n with None -> mt () | Some n -> pr_at_level (NumLevel n))
+    | SetAssoc LeftA -> keyword "left associativity"
+    | SetAssoc RightA -> keyword "right associativity"
+    | SetAssoc NonA -> keyword "no associativity"
+    | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_simple_entry_type typ
+    | SetOnlyPrinting -> keyword "only printing"
+    | SetOnlyParsing -> keyword "only parsing"
+    | SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"")
+    | SetFormat("text",s) -> keyword "format " ++ pr_ast qs s
+    | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_ast qs s
+
+  let pr_syntax_modifiers = function
+    | [] -> mt()
+    | l -> spc() ++
+      hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
+
+  let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) =
+    let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in
+    let annot = pr_guard_annot pr_lconstr_expr bl ro in
+    pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot
+    ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
+    ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def
+    ++ prlist (pr_decl_notation pr_constr) ntn
+
+  let pr_statement head (idpl,(bl,c)) =
+    hov 2
+      (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++
+         (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
+         str":" ++ pr_spc_lconstr c)
+
+(**************************************)
+(* Pretty printer for vernac commands *)
+(**************************************)
+
+  let pr_constrarg c = spc () ++ pr_constr c
+  let pr_lconstrarg c = spc () ++ pr_lconstr c
+  let pr_intarg n = spc () ++ int n
+
+  let pr_oc = function
+    | None -> str" :"
+    | Some true -> str" :>"
+    | Some false -> str" :>>"
+
+  let pr_record_field ((x, pri), ntn) =
+    let prx = match x with
+      | (oc,AssumExpr (id,t)) ->
+        hov 1 (pr_lname id ++
+                 pr_oc oc ++ spc() ++
+                 pr_lconstr_expr t)
+      | (oc,DefExpr(id,b,opt)) -> (match opt with
+          | Some t ->
+            hov 1 (pr_lname id ++
+                     pr_oc oc ++ spc() ++
+                     pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
+          | None ->
+            hov 1 (pr_lname id ++ str" :=" ++ spc() ++
+                     pr_lconstr b)) in
+    let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
+    prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
+
+  let pr_record_decl b c fs =
+    pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++
+      hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
+
+  let pr_printable = function
+    | PrintFullContext ->
+      keyword "Print All"
+    | PrintSectionContext s ->
+      keyword "Print Section" ++ spc() ++ Libnames.pr_qualid s
+    | PrintGrammar ent ->
+      keyword "Print Grammar" ++ spc() ++ str ent
+    | PrintLoadPath dir ->
+      keyword "Print LoadPath" ++ pr_opt DirPath.print dir
+    | PrintModules ->
+      keyword "Print Modules"
+    | PrintMLLoadPath ->
+      keyword "Print ML Path"
+    | PrintMLModules ->
+      keyword "Print ML Modules"
+    | PrintDebugGC ->
+      keyword "Print ML GC"
+    | PrintGraph ->
+      keyword "Print Graph"
+    | PrintClasses ->
+      keyword "Print Classes"
+    | PrintTypeClasses ->
+      keyword "Print TypeClasses"
+    | PrintInstances qid ->
+      keyword "Print Instances" ++ spc () ++ pr_smart_global qid
+    | PrintCoercions ->
+      keyword "Print Coercions"
+    | PrintCoercionPaths (s,t) ->
+      keyword "Print Coercion Paths" ++ spc()
+      ++ pr_class_rawexpr s ++ spc()
+      ++ pr_class_rawexpr t
+    | PrintCanonicalConversions ->
+      keyword "Print Canonical Structures"
+    | PrintTables ->
+      keyword "Print Tables"
+    | PrintHintGoal ->
+      keyword "Print Hint"
+    | PrintHint qid ->
+      keyword "Print Hint" ++ spc () ++ pr_smart_global qid
+    | PrintHintDb ->
+      keyword "Print Hint *"
+    | PrintHintDbName s ->
+      keyword "Print HintDb" ++ spc () ++ str s
+    | PrintUniverses (b, fopt) ->
+      let cmd =
+        if b then "Print Sorted Universes"
+        else "Print Universes"
+      in
+      keyword cmd ++ pr_opt str fopt
+    | PrintName (qid,udecl) ->
+      keyword "Print" ++ spc()  ++ pr_smart_global qid ++ pr_univ_name_list udecl
+    | PrintModuleType qid ->
+      keyword "Print Module Type" ++ spc() ++ pr_qualid qid
+    | PrintModule qid ->
+      keyword "Print Module" ++ spc() ++ pr_qualid qid
+    | PrintInspect n ->
+      keyword "Inspect" ++ spc() ++ int n
+    | PrintScopes ->
+      keyword "Print Scopes"
+    | PrintScope s ->
+      keyword "Print Scope" ++ spc() ++ str s
+    | PrintVisibility s ->
+      keyword "Print Visibility" ++ pr_opt str s
+    | PrintAbout (qid,l,gopt) ->
+       pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt
+       ++ keyword "About" ++ spc()  ++ pr_smart_global qid ++ pr_univ_name_list l
+    | PrintImplicit qid ->
+      keyword "Print Implicit" ++ spc()  ++ pr_smart_global qid
+    (* spiwack: command printing all the axioms and section variables used in a
+       term *)
+    | PrintAssumptions (b, t, qid) ->
+      let cmd = match b, t with
+        | true, true -> "Print All Dependencies"
+        | true, false -> "Print Opaque Dependencies"
+        | false, true -> "Print Transparent Dependencies"
+        | false, false -> "Print Assumptions"
+      in
+      keyword cmd ++ spc() ++ pr_smart_global qid
+    | PrintNamespace dp ->
+      keyword "Print Namespace" ++ DirPath.print dp
+    | PrintStrategy None ->
+      keyword "Print Strategies"
+    | PrintStrategy (Some qid) ->
+      keyword "Print Strategy" ++ pr_smart_global qid
+
+  let pr_using e =
+    let rec aux = function
+      | SsEmpty -> "()"
+      | SsType -> "(Type)"
+      | SsSingl { v=id } -> "("^Id.to_string id^")"
+      | SsCompl e -> "-" ^ aux e^""
+      | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")"
+      | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")"
+      | SsFwdClose e -> "("^aux e^")*"
+    in Pp.str (aux e)
+
+  let pr_extend s cl =
+    let pr_arg a =
+      try pr_gen a
+      with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in
+    try
+      let rl = Egramml.get_extend_vernac_rule s in
+      let rec aux rl cl =
+        match rl, cl with
+        | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl
+        | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl
+        | [], [] -> []
+        | _ -> assert false in
+      hov 1 (pr_sequence identity (aux rl cl))
+    with Not_found ->
+      hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")")
+
+  let pr_vernac_expr v =
+    let return = tag_vernac v in
+    match v with
+      | VernacLoad (f,s) ->
+        return (
+          keyword "Load"
+          ++ if f then
+              (spc() ++ keyword "Verbose" ++ spc())
+            else
+              spc() ++ qs s
+        )
+
+      (* Proof management *)
+      | VernacAbortAll ->
+        return (keyword "Abort All")
+      | VernacRestart ->
+        return (keyword "Restart")
+      | VernacUnfocus ->
+        return (keyword "Unfocus")
+      | VernacUnfocused ->
+        return (keyword "Unfocused")
+      | VernacAbort id ->
+        return (keyword "Abort" ++ pr_opt pr_lident id)
+      | VernacUndo i ->
+        return (
+          if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i
+        )
+      | VernacUndoTo i ->
+        return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i)
+      | VernacFocus i ->
+        return (keyword "Focus" ++ pr_opt int i)
+      | VernacShow s ->
+        let pr_goal_reference = function
+          | OpenSubgoals -> mt ()
+          | NthGoal n -> spc () ++ int n
+          | GoalId id -> spc () ++ pr_id id
+        in
+        let pr_showable = function
+          | ShowGoal n -> keyword "Show" ++ pr_goal_reference n
+          | ShowProof -> keyword "Show Proof"
+          | ShowScript -> keyword "Show Script"
+          | ShowExistentials -> keyword "Show Existentials"
+          | ShowUniverses -> keyword "Show Universes"
+          | ShowProofNames -> keyword "Show Conjectures"
+          | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro")
+          | ShowMatch id -> keyword "Show Match " ++ pr_qualid id
+        in
+        return (pr_showable s)
+      | VernacCheckGuard ->
+        return (keyword "Guarded")
+
+    (* Resetting *)
+      | VernacResetName id ->
+        return (keyword "Reset" ++ spc() ++ pr_lident id)
+      | VernacResetInitial ->
+        return (keyword "Reset Initial")
+      | VernacBack i ->
+        return (
+          if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i
+        )
+      | VernacBackTo i ->
+        return (keyword "BackTo" ++ pr_intarg i)
+
+    (* State management *)
+      | VernacWriteState s ->
+        return (keyword "Write State" ++ spc () ++ qs s)
+      | VernacRestoreState s ->
+        return  (keyword "Restore State" ++ spc() ++ qs s)
+
+    (* Syntax *)
+      | VernacOpenCloseScope (opening,sc) ->
+        return (
+          keyword (if opening then "Open " else "Close ") ++
+            keyword "Scope" ++ spc() ++ str sc
+        )
+      | VernacDelimiters (sc,Some key) ->
+        return (
+          keyword "Delimit Scope" ++ spc () ++ str sc ++
+            spc() ++ keyword "with" ++ spc () ++ str key
+        )
+      | VernacDelimiters (sc, None) ->
+        return (
+          keyword "Undelimit Scope" ++ spc () ++ str sc
+        )
+      | VernacBindScope (sc,cll) ->
+        return (
+          keyword "Bind Scope" ++ spc () ++ str sc ++
+            spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll
+        )
+      | VernacInfix (({v=s},mv),q,sn) -> (* A Verifier *)
+        return (
+          hov 0 (hov 0 (keyword "Infix "
+                        ++ qs s ++ str " :=" ++ pr_constrarg q) ++
+                   pr_syntax_modifiers mv ++
+                   (match sn with
+                     | None -> mt()
+                     | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
+        )
+      | VernacNotation (c,({v=s},l),opt) ->
+        return (
+          hov 2 (keyword "Notation" ++ spc() ++ qs s ++
+                   str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++
+                   (match opt with
+                     | None -> mt()
+                     | Some sc -> str" :" ++ spc() ++ str sc))
+        )
+      | VernacSyntaxExtension (_, (s, l)) ->
+        return (
+          keyword "Reserved Notation" ++ spc() ++ pr_ast qs s ++
+            pr_syntax_modifiers l
+        )
+      | VernacNotationAddFormat(s,k,v) ->
+        return (
+          keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v
+        )
+      | VernacDeclareCustomEntry s ->
+        return (
+          keyword "Declare Custom Entry " ++ str s
+        )
+
+      (* Gallina *)
+      | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *)
+        let pr_def_token dk =
+          keyword (
+            if Name.is_anonymous (fst id).v
+            then "Goal"
+            else Kindops.string_of_definition_object_kind dk)
+        in
+        let pr_reduce = function
+          | None -> mt()
+          | Some r ->
+            keyword "Eval" ++ spc() ++
+              pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++
+              keyword " in" ++ spc()
+        in
+        let pr_def_body = function
+          | DefineBody (bl,red,body,d) ->
+            let ty = match d with
+              | None -> mt()
+              | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+            in
+            (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
+          | ProveBody (bl,t) ->
+            let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in
+            (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in
+        let (binds,typ,c) = pr_def_body b in
+        return (
+          hov 2 (
+            pr_def_token kind ++ spc()
+            ++ pr_lname_decl id ++ binds ++ typ
+            ++ (match c with
+              | None -> mt()
+              | Some cc -> str" :=" ++ spc() ++ cc))
+        )
+
+      | VernacStartTheoremProof (ki,l) ->
+        return (
+          hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
+                   prlist (pr_statement (spc () ++ keyword "with")) (List.tl l))
+        )
+
+      | VernacEndProof Admitted ->
+        return (keyword "Admitted")
+
+      | VernacEndProof (Proved (opac,o)) -> return (
+        let open Proof_global in
+        match o with
+          | None -> (match opac with
+              | Transparent -> keyword "Defined"
+              | Opaque      -> keyword "Qed")
+          | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
+      )
+      | VernacExactProof c ->
+        return (hov 2 (keyword "Proof" ++ pr_lconstrarg c))
+      | VernacAssumption ((discharge,kind),t,l) ->
+        let n = List.length (List.flatten (List.map fst (List.map snd l))) in
+        let pr_params (c, (xl, t)) =
+          hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++
+            (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in
+        let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
+        return (hov 2 (pr_assumption_token (n > 1) discharge kind ++
+                       pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions))
+      | VernacInductive (cum, p,f,l) ->
+        let pr_constructor (coe,(id,c)) =
+          hov 2 (pr_lident id ++ str" " ++
+                   (if coe then str":>" else str":") ++
+                   Flags.without_option Flags.beautify pr_spc_lconstr c)
+        in
+        let pr_constructor_list b l = match l with
+          | Constructors [] -> mt()
+          | Constructors l ->
+            let fst_sep = match l with [_] -> "   " | _ -> " | " in
+            pr_com_at (begin_of_inductive l) ++
+              fnl() ++ str fst_sep ++
+              prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
+          | RecordDecl (c,fs) ->
+            pr_record_decl b c fs
+        in
+        let pr_oneind key (((coe,iddecl),indpar,s,k,lc),ntn) =
+          hov 0 (
+            str key ++ spc() ++
+              (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++
+              pr_and_type_binders_arg indpar ++
+              pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++
+              str" :=") ++ pr_constructor_list k lc ++
+            prlist (pr_decl_notation pr_constr) ntn
+        in
+        let key =
+          let (_,_,_,k,_),_ = List.hd l in
+          let kind =
+            match k with Record -> "Record" | Structure -> "Structure"
+                       | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
+                       | Class _ -> "Class" | Variant -> "Variant"
+          in
+          if p then
+            let cm =
+              match cum with
+              | Some VernacCumulative -> "Cumulative"
+              | Some VernacNonCumulative -> "NonCumulative"
+              | None -> ""
+            in
+            cm ^ " " ^ kind
+          else kind
+        in
+        return (
+          hov 1 (pr_oneind key (List.hd l)) ++
+          (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
+        )
+
+      | VernacFixpoint (local, recs) ->
+        let local = match local with
+          | DoDischarge -> "Let "
+          | NoDischarge -> ""
+        in
+        return (
+          hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
+                   prlist_with_sep (fun _ -> fnl () ++ keyword "with"
+                     ++ spc ()) pr_rec_definition recs)
+        )
+
+      | VernacCoFixpoint (local, corecs) ->
+        let local = match local with
+          | DoDischarge -> keyword "Let" ++ spc ()
+          | NoDischarge -> str ""
+        in
+        let pr_onecorec ((iddecl,bl,c,def),ntn) =
+          pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
+            spc() ++ pr_lconstr_expr c ++
+            pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
+            prlist (pr_decl_notation pr_constr) ntn
+        in
+        return (
+          hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++
+                   prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs)
+        )
+      | VernacScheme l ->
+        return (
+          hov 2 (keyword "Scheme" ++ spc() ++
+                   prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l)
+        )
+      | VernacCombinedScheme (id, l) ->
+        return (
+          hov 2 (keyword "Combined Scheme" ++ spc() ++
+                   pr_lident id ++ spc() ++ keyword "from" ++ spc() ++
+                   prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
+        )
+      | VernacUniverse v ->
+        return (
+          hov 2 (keyword "Universe" ++ spc () ++
+                   prlist_with_sep (fun _ -> str",") pr_lident v)
+        )
+      | VernacConstraint v ->
+        return (
+          hov 2 (keyword "Constraint" ++ spc () ++
+                   prlist_with_sep (fun _ -> str",") pr_uconstraint v)
+        )
+
+      (* Gallina extensions *)
+      | VernacBeginSection id ->
+        return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id))
+      | VernacEndSegment id ->
+        return (hov 2 (keyword "End" ++ spc() ++ pr_lident id))
+      | VernacNameSectionHypSet (id,set) ->
+        return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++
+        str ":="++spc()++pr_using set))
+      | VernacRequire (from, exp, l) ->
+        let from = match from with
+        | None -> mt ()
+        | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc ()
+        in
+        return (
+          hov 2
+            (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++
+               prlist_with_sep sep pr_module l)
+        )
+      | VernacImport (f,l) ->
+        return (
+          (if f then keyword "Export" else keyword "Import") ++ spc() ++
+            prlist_with_sep sep pr_import_module l
+        )
+      | VernacCanonical q ->
+        return (
+          keyword "Canonical Structure" ++ spc() ++ pr_smart_global q
+        )
+      | VernacCoercion (id,c1,c2) ->
+        return (
+          hov 1 (
+            keyword "Coercion" ++ spc() ++
+              pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+              spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
+        )
+      | VernacIdentityCoercion (id,c1,c2) ->
+        return (
+          hov 1 (
+            keyword "Identity Coercion" ++ spc() ++ pr_lident id ++
+              spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
+              spc() ++ pr_class_rawexpr c2)
+        )
+
+      | VernacInstance (abst, sup, (instid, bk, cl), props, info) ->
+        return (
+          hov 1 (
+            (if abst then keyword "Declare" ++ spc () else mt ()) ++
+            keyword "Instance" ++
+            (match instid with
+             | {loc; v = Name id}, l -> spc () ++ pr_ident_decl (CAst.(make ?loc id),l) ++ spc ()
+             | { v = Anonymous }, _ -> mt ()) ++
+            pr_and_type_binders_arg sup ++
+              str":" ++ spc () ++
+              (match bk with Implicit -> str "! " | Explicit -> mt ()) ++
+              pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++
+              (match props with
+                | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}"
+                | Some (true,_) -> assert false
+                | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
+                | None -> mt()))
+        )
+
+      | VernacContext l ->
+        return (
+          hov 1 (
+            keyword "Context" ++ pr_and_type_binders_arg l)
+        )
+
+      | VernacDeclareInstances insts ->
+         let pr_inst (id, info) =
+           pr_qualid id ++ pr_hint_info pr_constr_pattern_expr info
+         in
+         return (
+          hov 1 (keyword "Existing" ++ spc () ++
+                   keyword(String.plural (List.length insts) "Instance") ++
+                 spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts)
+        )
+
+      | VernacDeclareClass id ->
+        return (
+          hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_qualid id)
+        )
+
+      (* Modules and Module Types *)
+      | VernacDefineModule (export,m,bl,tys,bd) ->
+        let b = pr_module_binders bl pr_lconstr in
+        return (
+          hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++
+                   pr_lident m ++ b ++
+                   pr_of_module_type pr_lconstr tys ++
+                   (if List.is_empty bd then mt () else str ":= ") ++
+                   prlist_with_sep (fun () -> str " <+")
+                   (pr_module_ast_inl true pr_lconstr) bd)
+        )
+      | VernacDeclareModule (export,id,bl,m1) ->
+        let b = pr_module_binders bl pr_lconstr in
+        return (
+          hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++
+                   pr_lident id ++ b ++ str " :" ++
+                   pr_module_ast_inl true pr_lconstr m1)
+        )
+      | VernacDeclareModuleType (id,bl,tyl,m) ->
+        let b = pr_module_binders bl pr_lconstr in
+        let pr_mt = pr_module_ast_inl true pr_lconstr in
+        return (
+          hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++
+                   prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++
+                   (if List.is_empty m then mt () else str ":= ") ++
+                   prlist_with_sep (fun () -> str " <+ ") pr_mt m)
+        )
+      | VernacInclude (mexprs) ->
+        let pr_m = pr_module_ast_inl false pr_lconstr in
+        return (
+          hov 2 (keyword "Include" ++ spc() ++
+                   prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
+        )
+      (* Solving *)
+      | VernacSolveExistential (i,c) ->
+        return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c)
+
+      (* Auxiliary file and library management *)
+      | VernacAddLoadPath (fl,s,d) ->
+        return (
+          hov 2
+            (keyword "Add" ++
+               (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++
+               keyword "LoadPath" ++ spc() ++ qs s ++
+               (match d with
+                 | None -> mt()
+                 | Some dir -> spc() ++ keyword "as" ++ spc() ++ DirPath.print dir))
+        )
+      | VernacRemoveLoadPath s ->
+        return (keyword "Remove LoadPath" ++ qs s)
+      | VernacAddMLPath (fl,s) ->
+        return (
+          keyword "Add"
+          ++ (if fl then spc () ++ keyword "Rec" ++ spc () else spc())
+          ++ keyword "ML Path"
+          ++ qs s
+        )
+      | VernacDeclareMLModule (l) ->
+        return (
+          hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
+        )
+      | VernacChdir s ->
+        return (keyword "Cd" ++ pr_opt qs s)
+
+      (* Commands *)
+      | VernacCreateHintDb (dbname,b) ->
+        return (
+          hov 1 (keyword "Create HintDb" ++ spc () ++
+                   str dbname ++ (if b then str" discriminated" else mt ()))
+        )
+      | VernacRemoveHints (dbnames, ids) ->
+        return (
+          hov 1 (keyword "Remove Hints" ++ spc () ++
+                   prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++
+                   pr_opt_hintbases dbnames)
+        )
+      | VernacHints (dbnames,h) ->
+        return (pr_hints dbnames h pr_constr pr_constr_pattern_expr)
+      | VernacSyntacticDefinition (id,(ids,c),compat) ->
+        return (
+          hov 2
+            (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
+               prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++
+               pr_syntax_modifiers
+               (match compat with
+                | None -> []
+                | Some Flags.Current -> [SetOnlyParsing]
+                | Some v -> [SetCompatVersion v]))
+        )
+      | VernacArguments (q, args, more_implicits, nargs, mods) ->
+        return (
+          hov 2 (
+            keyword "Arguments" ++ spc() ++
+              pr_smart_global q ++
+              let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in
+              let pr_if b x = if b then x else str "" in
+              let pr_br imp x = match imp with
+                | Vernacexpr.Implicit -> str "[" ++ x ++ str "]"
+                | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}"
+                | Vernacexpr.NotImplicit -> x in
+              let rec print_arguments n l =
+                match n, l with
+                  | Some 0, l -> spc () ++ str"/" ++ print_arguments None l
+                  | _, [] -> mt()
+                  | n, { name = id; recarg_like = k;
+                         notation_scope = s;
+                         implicit_status = imp } :: tl ->
+                    spc() ++ pr_br imp (pr_if k (str"!") ++ Name.print id ++ pr_s s) ++
+                      print_arguments (Option.map pred n) tl
+              in
+              let rec print_implicits = function
+                | [] -> mt ()
+                | (name, impl) :: rest ->
+                   spc() ++ pr_br impl (Name.print name) ++ print_implicits rest
+              in
+              print_arguments nargs args ++
+                if not (List.is_empty more_implicits) then
+                  prlist (fun l -> str"," ++ print_implicits l) more_implicits
+                else (mt ()) ++
+                (if not (List.is_empty mods) then str" : " else str"") ++
+                  prlist_with_sep (fun () -> str", " ++ spc()) (function
+                    | `ReductionDontExposeCase -> keyword "simpl nomatch"
+                    | `ReductionNeverUnfold -> keyword "simpl never"
+                    | `DefaultImplicits -> keyword "default implicits"
+                    | `Rename -> keyword "rename"
+                    | `Assert -> keyword "assert"
+                    | `ExtraScopes -> keyword "extra scopes"
+                    | `ClearImplicits -> keyword "clear implicits"
+                    | `ClearScopes -> keyword "clear scopes")
+                  mods)
+        )
+      | VernacReserve bl ->
+        let n = List.length (List.flatten (List.map fst bl)) in
+        return (
+          hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " "))
+                 ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
+        )
+      | VernacGeneralizable g ->
+        return (
+          hov 1 (tag_keyword (
+            str"Generalizable Variable" ++
+              match g with
+                | None -> str "s none"
+                | Some [] -> str "s all"
+                | Some idl ->
+                  str (if List.length idl > 1 then "s " else " ") ++
+                    prlist_with_sep spc pr_lident idl)
+          ))
+      | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k ->
+        return (
+          hov 1 (keyword "Transparent" ++
+                   spc() ++ prlist_with_sep sep pr_smart_global l)
+        )
+      | VernacSetOpacity(Conv_oracle.Opaque,l) ->
+        return (
+          hov 1 (keyword "Opaque" ++
+                   spc() ++ prlist_with_sep sep pr_smart_global l)
+        )
+      | VernacSetOpacity _ ->
+        return (
+          CErrors.anomaly (keyword "VernacSetOpacity used to set something else.")
+        )
+      | VernacSetStrategy l ->
+        let pr_lev = function
+          | Conv_oracle.Opaque -> keyword "opaque"
+          | Conv_oracle.Expand -> keyword "expand"
+          | l when Conv_oracle.is_transparent l -> keyword "transparent"
+          | Conv_oracle.Level n -> int n
+        in
+        let pr_line (l,q) =
+          hov 2 (pr_lev l ++ spc() ++
+                   str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]")
+        in
+        return (
+          hov 1 (keyword "Strategy" ++ spc() ++
+                   hv 0 (prlist_with_sep sep pr_line l))
+        )
+      | VernacUnsetOption (export, na) ->
+        let export = if export then keyword "Export" ++ spc () else mt () in
+        return (
+          hov 1 (export ++ keyword "Unset" ++ spc() ++ pr_printoption na None)
+        )
+      | VernacSetOption (export, na,v) ->
+        let export = if export then keyword "Export" ++ spc () else mt () in
+        return (
+          hov 2 (export ++ keyword "Set" ++ spc() ++ pr_set_option na v)
+        )
+      | VernacAddOption (na,l) ->
+        return (
+          hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l))
+        )
+      | VernacRemoveOption (na,l) ->
+        return (
+          hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l))
+        )
+      | VernacMemOption (na,l) ->
+        return (
+          hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l))
+        )
+      | VernacPrintOption na ->
+        return (
+          hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None)
+        )
+      | VernacCheckMayEval (r,io,c) ->
+        let pr_mayeval r c = match r with
+          | Some r0 ->
+            hov 2 (keyword "Eval" ++ spc() ++
+                     pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++
+                     spc() ++ keyword "in" ++ spc () ++ pr_lconstr c)
+          | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c)
+        in
+        let pr_i = match io with None -> mt ()
+                               | Some i -> Goal_select.pr_goal_selector i ++ str ": " in
+        return (pr_i ++ pr_mayeval r c)
+      | VernacGlobalCheck c ->
+        return (hov 2 (keyword "Type" ++ pr_constrarg c))
+      | VernacDeclareReduction (s,r) ->
+        return (
+          keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++
+            pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r
+        )
+      | VernacPrint p ->
+        return (pr_printable p)
+      | VernacSearch (sea,g,sea_r) ->
+        return (pr_search sea g sea_r pr_constr_pattern_expr)
+      | VernacLocate loc ->
+        let pr_locate =function
+          | LocateAny qid -> pr_smart_global qid
+          | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid
+          | LocateFile f -> keyword "File" ++ spc() ++ qs f
+          | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid
+          | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid
+          | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid
+        in
+        return (keyword "Locate" ++ spc() ++ pr_locate loc)
+      | VernacRegister (id, RegisterInline) ->
+        return (
+          hov 2
+            (keyword "Register Inline" ++ spc() ++ pr_lident id)
+        )
+      | VernacComments l ->
+        return (
+          hov 2
+            (keyword "Comments" ++ spc()
+             ++ prlist_with_sep sep (pr_comment pr_constr) l)
+        )
+
+      (* For extension *)
+      | VernacExtend (s,c) ->
+        return (pr_extend s c)
+      | VernacProof (None, None) ->
+        return (keyword "Proof")
+      | VernacProof (None, Some e) ->
+        return (keyword "Proof " ++ spc () ++
+            keyword "using" ++ spc() ++ pr_using e)
+      | VernacProof (Some te, None) ->
+        return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te)
+      | VernacProof (Some te, Some e) ->
+        return (
+          keyword "Proof" ++ spc () ++
+            keyword "using" ++ spc() ++ pr_using e ++ spc() ++
+            keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te
+        )
+      | VernacProofMode s ->
+        return (keyword "Proof Mode" ++ str s)
+      | VernacBullet b ->
+        (* XXX: Redundant with Proof_bullet.print *)
+        return (let open Proof_bullet in begin match b with
+          | Dash n -> str (String.make n '-')
+          | Star n -> str (String.make n '*')
+          | Plus n -> str (String.make n '+')
+        end)
+      | VernacSubproof None ->
+        return (str "{")
+      | VernacSubproof (Some i) ->
+        return (Goal_select.pr_goal_selector i ++ str ":" ++ spc () ++ str "{")
+      | VernacEndSubproof ->
+        return (str "}")
+
+let rec pr_vernac_flag (k, v) =
+  let k = keyword k in
+  match v with
+  | VernacFlagEmpty -> k
+  | VernacFlagLeaf v -> k ++ str " = " ++ qs v
+  | VernacFlagList m -> k ++ str "( " ++ pr_vernac_flags m ++ str " )"
+and pr_vernac_flags m =
+  prlist_with_sep (fun () -> str ", ") pr_vernac_flag m
+
+let pr_vernac_attributes =
+  function
+  | [] -> mt ()
+  | flags ->  str "#[" ++ pr_vernac_flags flags ++ str "]" ++ cut ()
+
+  let rec pr_vernac_control v =
+    let return = tag_vernac v in
+    match v with
+    | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v'
+    | VernacTime (_,{v}) ->
+      return (keyword "Time" ++ spc() ++ pr_vernac_control v)
+    | VernacRedirect (s, {v}) ->
+      return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v)
+    | VernacTimeout(n,v) ->
+      return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v)
+    | VernacFail v ->
+      return (keyword "Fail" ++ spc() ++ pr_vernac_control v)
+
+    let pr_vernac v =
+      try pr_vernac_control v
+      with e -> CErrors.print e
diff --git a/vernac/ppvernac.mli b/vernac/ppvernac.mli
new file mode 100644
index 00000000..4aa24bf5
--- /dev/null
+++ b/vernac/ppvernac.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+(** This module implements pretty-printers for vernac_expr syntactic
+    objects and their subcomponents. *)
+
+val pr_set_entry_type : ('a -> Pp.t) -> 'a Extend.constr_entry_key_gen -> Pp.t
+
+(** Prints a fixpoint body *)
+val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t
+
+(** Prints a vernac expression without dot *)
+val pr_vernac_expr : Vernacexpr.vernac_expr -> Pp.t
+
+(** Prints a "proof using X" clause. *)
+val pr_using : Vernacexpr.section_subset_expr -> Pp.t
+
+(** Prints a vernac expression and closes it with a dot. *)
+val pr_vernac : Vernacexpr.vernac_control -> Pp.t
diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml
index f8b085f3..3e2bd987 100644
--- a/vernac/proof_using.ml
+++ b/vernac/proof_using.ml
@@ -18,14 +18,6 @@ module NamedDecl = Context.Named.Declaration
 
 let known_names = Summary.ref [] ~name:"proofusing-nameset"
 
-let in_nameset =
-  let open Libobject in
-  declare_object { (default_object "proofusing-nameset") with
-    cache_function = (fun (_,x) -> known_names := x :: !known_names);
-    classify_function = (fun _ -> Dispose);
-    discharge_function = (fun _ -> None)
-  }
-
 let rec close_fwd e s =
   let s' =
     List.fold_left (fun s decl ->
@@ -73,7 +65,7 @@ let process_expr env e ty =
   let s = Id.Set.union v_ty (process_expr env e ty) in
   Id.Set.elements s
 
-let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr))
+let name_set id expr = known_names := (id,expr) :: !known_names
 
 let minimize_hyps env ids =
   let rec aux ids =
@@ -178,7 +170,7 @@ let suggest_variable env id =
 let value = ref None
 
 let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us)
-let using_from_string us = Pcoq.Gram.(entry_parse G_vernac.section_subset_expr (parsable (Stream.of_string us)))
+let using_from_string us = Pcoq.Entry.parse G_vernac.section_subset_expr (Pcoq.Parsable.make (Stream.of_string us))
 
 let _ =
   Goptions.declare_stringopt_option
diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml
new file mode 100644
index 00000000..b2fa8ec9
--- /dev/null
+++ b/vernac/pvernac.ml
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Pcoq
+
+let uvernac = create_universe "vernac"
+
+module Vernac_ =
+  struct
+    let gec_vernac s = Entry.create ("vernac:" ^ s)
+
+    (* The different kinds of vernacular commands *)
+    let gallina = gec_vernac "gallina"
+    let gallina_ext = gec_vernac "gallina_ext"
+    let command = gec_vernac "command"
+    let syntax = gec_vernac "syntax_command"
+    let vernac_control = gec_vernac "Vernac.vernac_control"
+    let rec_definition = gec_vernac "Vernac.rec_definition"
+    let red_expr = new_entry utactic "red_expr"
+    let hint_info = gec_vernac "hint_info"
+    (* Main vernac entry *)
+    let main_entry = Entry.create "vernac"
+    let noedit_mode = gec_vernac "noedit_command"
+
+    let () =
+      let open Extend in
+      let act_vernac v loc = Some (loc, v) in
+      let act_eoi _ loc = None in
+      let rule = [
+        Rule (Next (Stop, Atoken Tok.EOI), act_eoi);
+        Rule (Next (Stop, Aentry vernac_control), act_vernac);
+      ] in
+      Pcoq.grammar_extend main_entry None (None, [None, None, rule])
+
+    let command_entry_ref = ref noedit_mode
+    let command_entry =
+      Gram.Entry.of_parser "command_entry"
+        (fun strm -> Gram.Entry.parse_token !command_entry_ref strm)
+
+  end
+
+let main_entry = Vernac_.main_entry
+
+let set_command_entry e = Vernac_.command_entry_ref := e
+let get_command_entry () = !Vernac_.command_entry_ref
+
+let () =
+  register_grammar Stdarg.wit_red_expr (Vernac_.red_expr);
diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli
new file mode 100644
index 00000000..b2f8f714
--- /dev/null
+++ b/vernac/pvernac.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Pcoq
+open Genredexpr
+open Vernacexpr
+
+val uvernac : gram_universe
+
+module Vernac_ :
+  sig
+    val gallina : vernac_expr Entry.t
+    val gallina_ext : vernac_expr Entry.t
+    val command : vernac_expr Entry.t
+    val syntax : vernac_expr Entry.t
+    val vernac_control : vernac_control Entry.t
+    val rec_definition : (fixpoint_expr * decl_notation list) Entry.t
+    val noedit_mode : vernac_expr Entry.t
+    val command_entry : vernac_expr Entry.t
+    val red_expr : raw_red_expr Entry.t
+    val hint_info : Hints.hint_info_expr Entry.t
+  end
+
+(** The main entry: reads an optional vernac command *)
+val main_entry : (Loc.t * vernac_control) option Entry.t
+
+(** Handling of the proof mode entry *)
+val get_command_entry : unit -> vernac_expr Entry.t
+val set_command_entry : vernac_expr Entry.t -> unit
diff --git a/vernac/record.ml b/vernac/record.ml
index 78e68e8a..8dd123de 100644
--- a/vernac/record.ml
+++ b/vernac/record.ml
@@ -96,13 +96,13 @@ 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   -> CAst.make ?loc:n.CAst.loc @@ CHole (None, Misctypes.IntroAnonymous, None))
+                          | None   -> CAst.make ?loc:n.CAst.loc @@ CHole (None, Namegen.IntroAnonymous, None))
 
 let binders_of_decls = List.map binder_of_decl
 
-let typecheck_params_and_fields finite def id poly pl t ps nots fs =
+let typecheck_params_and_fields finite def poly pl ps records =
   let env0 = Global.env () in
-  let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in
+  let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in
   let _ =
     let error bk {CAst.loc; v=name} =
       match bk, name with
@@ -117,12 +117,12 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs =
               Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps
   in 
   let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars env0 sigma ps in
-  let sigma, typ, sort, template = match t with
+  let fold (sigma, template) (_, t, _, _) = match t with
     | Some t -> 
        let env = EConstr.push_rel_context newps env0 in
        let poly =
          match t with
-         | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in
+         | { CAst.v = CSort (Glob_term.GType []) } -> true | _ -> false in
        let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in
        let sred = Reductionops.whd_allnolet env sigma s in
          (match EConstr.kind sigma sred with
@@ -132,28 +132,36 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs =
                match Evd.is_sort_variable sigma s' with
                | Some l ->
                  let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in
-                 sigma, s, s', true
+                 (sigma, template), (s, s')
                | None ->
-                 sigma, s, s', false
-             else sigma, s, s', false)
+                 (sigma, false), (s, s')
+             else (sigma, false), (s, s'))
 	 | _ -> user_err ?loc:(constr_loc t) (str"Sort expected."))
     | None -> 
       let uvarkind = Evd.univ_flexible_alg in
       let sigma, s = Evd.new_sort_variable uvarkind sigma in
-      sigma, EConstr.mkSort s, s, true
+      (sigma, template), (EConstr.mkSort s, s)
   in
-  let arity = EConstr.it_mkProd_or_LetIn typ newps in
-  let env_ar = EConstr.push_rel_context newps (EConstr.push_rel (LocalAssum (Name id,arity)) env0) in
+  let (sigma, template), typs = List.fold_left_map fold (sigma, true) records in
+  let arities = List.map (fun (typ, _) -> EConstr.it_mkProd_or_LetIn typ newps) typs in
+  let fold accu (id, _, _, _) arity = EConstr.push_rel (LocalAssum (Name id,arity)) accu in
+  let env_ar = EConstr.push_rel_context newps (List.fold_left2 fold env0 records arities) in
   let assums = List.filter is_local_assum newps in
-  let params = List.map (RelDecl.get_name %> Name.get_id) assums in
-  let ty = Inductive (params,(finite != Declarations.BiFinite)) in
-  let impls_env = compute_internalization_env env0 sigma ~impls:impls_env ty [id] [arity] [imps] in
-  let env2,sigma,impls,newfs,data =
-    interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs)
+  let impls_env =
+    let params = List.map (RelDecl.get_name %> Name.get_id) assums in
+    let ty = Inductive (params, (finite != Declarations.BiFinite)) in
+    let ids = List.map (fun (id, _, _, _) -> id) records in
+    let imps = List.map (fun _ -> imps) arities in
+    compute_internalization_env env0 sigma ~impls:impls_env ty ids arities imps
   in
+  let fold sigma (_, _, nots, fs) arity =
+    let _, sigma, impls, newfs, _ = interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in
+    (sigma, (impls, newfs))
+  in
+  let (sigma, data) = List.fold_left2_map fold sigma records arities in
   let sigma =
-    Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma Evd.empty in
-  let sigma, typ =
+    Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma (Evd.from_env env_ar) in
+  let fold sigma (typ, sort) (_, newfs) =
     let _, univ = compute_constructor_level sigma env_ar newfs in
       if not def && (Sorts.is_prop sort ||
 	(Sorts.is_set sort && is_impredicative_set env0)) then
@@ -164,20 +172,24 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs =
            Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then
 	   (* We can assume that the level in aritysort is not constrained
 	       and clear it, if it is flexible *)
-          Evd.set_eq_sort env_ar sigma (Prop Pos) sort,
-          EConstr.mkSort (Sorts.sort_of_univ univ)
+   Evd.set_eq_sort env_ar sigma Set sort, EConstr.mkSort (Sorts.sort_of_univ univ)
         else sigma, typ
   in
-  let sigma, _ = Evarutil.nf_evars_and_universes sigma in
-  let newfs = List.map (EConstr.to_rel_decl sigma) newfs in
+  let (sigma, typs) = List.fold_left2_map fold sigma typs data in
+  let sigma = Evd.minimize_universes sigma in
   let newps = List.map (EConstr.to_rel_decl sigma) newps in
-  let typ = EConstr.to_constr sigma typ in
-  let ce t = Pretyping.check_evars env0 Evd.empty sigma (EConstr.of_constr t) in
   let univs = Evd.check_univ_decl ~poly sigma decl in
   let ubinders = Evd.universe_binders sigma in
-    List.iter (iter_constr ce) (List.rev newps);
+  let ce t = Pretyping.check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr t) in
+  let () = List.iter (iter_constr ce) (List.rev newps) in
+  let map (impls, newfs) typ =
+    let newfs = List.map (EConstr.to_rel_decl sigma) newfs in
+    let typ = EConstr.to_constr sigma typ in
     List.iter (iter_constr ce) (List.rev newfs);
-    ubinders, univs, typ, template, imps, newps, impls, newfs
+    (typ, impls, newfs)
+  in
+  let ans = List.map2 map data typs in
+  ubinders, univs, template, newps, imps, ans
 
 let degenerate_decl decl =
   let id = match RelDecl.get_name decl with
@@ -261,9 +273,10 @@ let subst_projection fid l c =
     raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
   c''
 
-let instantiate_possibly_recursive_type indu paramdecls fields =
+let instantiate_possibly_recursive_type ind u ntypes paramdecls fields =
   let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in
-  Termops.substl_rel_context (subst@[mkIndU indu]) fields
+  let subst' = List.init ntypes (fun i -> mkIndU ((ind, ntypes - i - 1), u)) in
+  Termops.substl_rel_context (subst @ subst') fields
 
 let warn_non_primitive_record =
   CWarnings.create ~name:"non-primitive-record" ~category:"record"
@@ -281,19 +294,18 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u
     | Monomorphic_const_entry ctx -> Univ.Instance.empty
   in
   let paramdecls = Inductive.inductive_paramdecls (mib, u) in
-  let indu = indsp, u in
   let r = mkIndU (indsp,u) in
   let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in
   let paramargs = Context.Rel.to_extended_list mkRel 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 fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes 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
+        | PrimRecord _ -> true
+        | FakeRecord | NotRecord -> false
       in
 	if not is_primitive then 
 	  warn_non_primitive_record (env,indsp);
@@ -312,12 +324,16 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u
 	  | Name fid -> try
 	    let kn, term = 
 	      if is_local_assum decl && primitive then
-		(** Already defined in the kernel silently *)
-                let gr = Nametab.locate (Libnames.qualid_of_ident fid) in
-                let kn = destConstRef gr in
+                let p = Projection.Repr.make indsp
+                    ~proj_npars:mib.mind_nparams
+                    ~proj_arg:i
+                    (Label.of_id fid)
+                in
+                (** Already defined by declare_mind silently *)
+                let kn = Projection.Repr.constant p in
                 Declare.definition_message fid;
-                Universes.register_universe_binders gr ubinders;
-                kn, mkProj (Projection.make kn false,mkRel 1)
+                UnivNames.register_universe_binders (ConstRef kn) ubinders;
+                kn, mkProj (Projection.make p false,mkRel 1)
 	      else
 		let ccl = subst_projection fid subst ti in
 		let body = match decl with
@@ -352,7 +368,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u
 		      applist (mkConstU (kn,u),proj_args) 
                   in
                   Declare.definition_message fid;
-                  Universes.register_universe_binders (ConstRef kn) ubinders;
+                  UnivNames.register_universe_binders (ConstRef kn) ubinders;
 		    kn, constr_fip
                 with Type_errors.TypeError (ctx,te) ->
                   raise (NotDefinable (BadTypedProj (fid,ctx,te))) 
@@ -374,12 +390,9 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u
 
 open Typeclasses
 
-let declare_structure finite ubinders univs id idbuild paramimpls params arity template
-    fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers =
-  let nparams = List.length params and nfields = List.length fields in
-  let args = Context.Rel.to_extended_list mkRel nfields params in
-  let ind = applist (mkRel (1+nparams+nfields), args) in
-  let type_constructor = it_mkProd_or_LetIn ind fields in
+
+let declare_structure finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data =
+  let nparams = List.length params in
   let template, ctx =
     match univs with
     | Monomorphic_ind_entry ctx ->
@@ -389,37 +402,51 @@ let declare_structure finite ubinders univs id idbuild paramimpls params arity t
     | Cumulative_ind_entry cumi ->
       false, Polymorphic_const_entry (Univ.CumulativityInfo.univ_context cumi)
   in
-  let binder_name = 
+  let binder_name =
     match name with
-    | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) 
+    | None ->
+      let map (id, _, _, _, _, _, _) =
+        Id.of_string (Unicode.lowercase_first_char (Id.to_string id))
+      in
+      Array.map_of_list map record_data
     | Some n -> n
   in
-  let mie_ind =
+  let ntypes = List.length record_data in
+  let mk_block i (id, idbuild, arity, _, fields, _, _) =
+    let nfields = List.length fields in
+    let args = Context.Rel.to_extended_list mkRel nfields params in
+    let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in
+    let type_constructor = it_mkProd_or_LetIn ind fields in
     { mind_entry_typename = id;
       mind_entry_arity = arity;
       mind_entry_template = template;
       mind_entry_consnames = [idbuild];
       mind_entry_lc = [type_constructor] }
   in
+  let blocks = List.mapi mk_block record_data 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_inds = blocks;
       mind_entry_private = None;
       mind_entry_universes = univs;
     }
   in
   let mie = InferCumulativity.infer_inductive (Global.env ()) mie in
-  let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders [(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 ctx ~kind binder_name coers ubinders fieldimpls fields in
-  let build = ConstructRef cstr in
-  let poly = match ctx with | Polymorphic_const_entry _ -> true | Monomorphic_const_entry _ -> false 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 impls = List.map (fun _ -> paramimpls, []) record_data in
+  let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls in
+  let map i (_, _, _, fieldimpls, fields, is_coe, coers) =
+    let rsp = (kn, i) in (* This is ind path of idstruc *)
+    let cstr = (rsp, 1) in
+    let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers ubinders fieldimpls fields in
+    let build = ConstructRef cstr in
+    let poly = match ctx with | Polymorphic_const_entry _ -> true | Monomorphic_const_entry _ -> false in
+    let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in
+    let () = Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs) in
+    rsp
+  in
+  List.mapi map record_data
 
 let implicits_of_context ctx =
   List.map_i (fun i name ->
@@ -431,28 +458,29 @@ let implicits_of_context ctx =
     1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx)))
 
 let declare_class finite def cum ubinders univs id idbuild paramimpls params arity
-    template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities =
+    template fieldimpls fields ?(kind=StructureComponent) coers priorities =
   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.vars_of_env (Global.env())) in
-  let impl, projs =
+  let binder_name = Namegen.next_ident_away id (Termops.vars_of_env (Global.env())) in
+  let data =
     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 ~univs class_body in
-      let cst = Declare.declare_constant (snd id)
+      let cst = Declare.declare_constant id
 	(DefinitionEntry class_entry, IsDefinition Definition)
       in
-      let cstu = (cst, match univs with
-        | Polymorphic_const_entry univs -> Univ.UContext.instance univs
-        | Monomorphic_const_entry _ -> Univ.Instance.empty)
+      let inst, univs = match univs with
+        | Polymorphic_const_entry uctx -> Univ.UContext.instance uctx, univs
+        | Monomorphic_const_entry _ -> Univ.Instance.empty, Monomorphic_const_entry Univ.ContextSet.empty
       in
+      let cstu = (cst, inst) in
       let inst_type = appvectc (mkConstU cstu)
 			       (Termops.rel_vect 0 (List.length params)) in
       let proj_type =
@@ -465,15 +493,15 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari
       in
       let cref = ConstRef cst in
       Impargs.declare_manual_implicits false cref [paramimpls];
-      Universes.register_universe_binders cref ubinders;
+      UnivNames.register_universe_binders cref ubinders;
       Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls];
-      Universes.register_universe_binders (ConstRef proj_cst) ubinders;
+      UnivNames.register_universe_binders (ConstRef proj_cst) ubinders;
       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]
+      [cref, [Name proj_name, sub, Some proj_cst]]
     | _ ->
        let univs =
          match univs with
@@ -485,18 +513,21 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari
          | Monomorphic_const_entry univs ->
            Monomorphic_ind_entry univs
        in
-       let ind = declare_structure Declarations.BiFinite ubinders univs (snd id) idbuild paramimpls
-	  params arity template fieldimpls fields
-          ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields)
-       in
+      let record_data = [id, idbuild, arity, fieldimpls, fields, false, List.map (fun _ -> false) fields] in
+      let inds = declare_structure Declarations.BiFinite ubinders univs paramimpls
+        params template ~kind:Method ~name:[|binder_name|] record_data
+      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 -> RelDecl.get_name decl, b, y)
-         (List.rev fields) coers (Recordops.lookup_projections ind)
-       in IndRef ind, l
+      let map ind =
+        let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y)
+          (List.rev fields) coers (Recordops.lookup_projections ind)
+        in IndRef ind, l
+      in
+      List.map map inds
   in
   let ctx_context =
     List.map (fun decl ->
@@ -517,16 +548,19 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari
     | Monomorphic_const_entry _ ->
       Univ.AUContext.empty, ctx_context, fields
   in
-  let k =
-    { cl_univs = univs;
-      cl_impl = impl;
-      cl_strict = !typeclasses_strict;
-      cl_unique = !typeclasses_unique;
-      cl_context = ctx_context;
-      cl_props = fields;
-      cl_projs = projs }
-  in
+  let map (impl, projs) =
+    let k =
+      { cl_univs = univs;
+        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
+  in
+  List.map map data
 
 
 let add_constant_class cst =
@@ -562,48 +596,87 @@ let add_inductive_class ind =
 	cl_unique = !typeclasses_unique }
   in add_class k
 
+let warn_already_existing_class =
+  CWarnings.create ~name:"already-existing-class" ~category:"automation" Pp.(fun g ->
+      Printer.pr_global g ++ str " is already declared as a typeclass.")
+
 let declare_existing_class g =
-  match g with
-  | ConstRef x -> add_constant_class x
-  | IndRef x -> add_inductive_class x
-  | _ -> user_err ~hdr:"declare_existing_class"
-		      (Pp.str"Unsupported class type, only constants and inductives are allowed")
+  if Typeclasses.is_class g then warn_already_existing_class g
+  else
+    match g with
+    | ConstRef x -> add_constant_class x
+    | IndRef x -> add_inductive_class x
+    | _ -> user_err ~hdr:"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,cum,poly,finite,(is_coe,({CAst.loc;v=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
+let check_unique_names records =
+  let extract_name acc (((_, bnd), _), _) = match bnd with
       Vernacexpr.AssumExpr({CAst.v=Name id},_) -> id::acc
     | Vernacexpr.DefExpr ({CAst.v=Name id},_,_) -> id::acc
     | _ -> acc in
-  let allnames =  idstruc::(List.fold_left extract_name [] fs) in
-  let () = match List.duplicates Id.equal allnames with
+  let allnames =
+    List.fold_left (fun acc (_, id, _, _, cfs, _, _) ->
+      id.CAst.v :: (List.fold_left extract_name acc cfs)) [] records
+  in
+  match List.duplicates Id.equal allnames with
   | [] -> ()
   | id :: _ -> user_err (str "Two objects have the same name" ++ spc () ++ quote (Id.print id))
-  in
+
+let check_priorities kind records =
   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
-    user_err Pp.(str "Priorities only allowed for type class substructures");
-  (* Now, younger decl in params and fields is on top *)
-  let pl, univs, arity, template, implpars, params, implfs, fields =
+  let has_priority (_, _, _, _, cfs, _, _) =
+    List.exists (fun ((_, pri), _) -> not (Option.is_empty pri)) cfs
+  in
+  if isnot_class && List.exists has_priority records then
+    user_err Pp.(str "Priorities only allowed for type class substructures")
+
+let extract_record_data records =
+  let map (is_coe, id, _, _, cfs, idbuild, s) =
+    let fs = List.map (fun (((_, f), _), _) -> f) cfs in
+    id.CAst.v, s, List.map snd cfs, fs
+  in
+  let data = List.map map records in
+  let pss = List.map (fun (_, _, _, ps, _, _, _) -> ps) records in
+  let ps = match pss with
+  | [] -> CErrors.anomaly (str "Empty record block")
+  | ps :: rem ->
+    let eq_local_binders bl1 bl2 = List.equal local_binder_eq bl1 bl2 in
+    let () =
+      if not (List.for_all (eq_local_binders ps) rem) then
+        user_err (str "Parameters should be syntactically the \
+          same for each inductive type.")
+    in
+    ps
+  in
+  (** FIXME: Same issue as #7754 *)
+  let _, _, pl, _, _, _, _ = List.hd records in
+  pl, ps, data
+
+(* [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 cum poly finite records =
+  let () = check_unique_names records in
+  let () = check_priorities kind records in
+  let pl, ps, data = extract_record_data records in
+  let pl, univs, template, params, implpars, data =
     States.with_state_protection (fun () ->
-      typecheck_params_and_fields finite (kind = Class true) idstruc poly pl s ps notations fs) () in
+      typecheck_params_and_fields finite (kind = Class true) poly pl ps data) () in
   match kind with
   | Class def ->
-    let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in
-    declare_class finite def cum pl univs (loc,idstruc) idbuild
-      implpars params arity template implfs fields is_coe coers priorities
+    let (_, id, _, _, cfs, idbuild, _), (arity, implfs, fields) = match records, data with
+    | [r], [d] -> r, d
+    | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled")
+    in
+    let priorities = List.map (fun ((_, id), _) -> {hint_priority = id; hint_pattern = None}) cfs in
+    let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in
+    declare_class finite def cum pl univs id.CAst.v idbuild
+      implpars params arity template implfs fields coers priorities
   | _ ->
-      let implfs = List.map
-	  (fun impls -> implpars @ Impargs.lift_implicits
-	           (succ (List.length params)) impls) implfs 
-      in
+    let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in
+    let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in
       let univs =
         match univs with
         | Polymorphic_const_entry univs ->
@@ -614,7 +687,11 @@ let definition_structure (kind,cum,poly,finite,(is_coe,({CAst.loc;v=idstruc},pl)
         | Monomorphic_const_entry univs ->
           Monomorphic_ind_entry univs
       in
-      let ind = declare_structure finite pl univs idstruc
-	  idbuild implpars params arity template implfs 
-          fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) in
-      IndRef ind
+    let map (arity, implfs, fields) (is_coe, id, _, _, cfs, idbuild, _) =
+      let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in
+      let coe = List.map (fun coe -> not (Option.is_empty coe)) coers in
+      id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe
+    in
+    let data = List.map2 map data records in
+    let inds = declare_structure finite pl univs implpars params template data in
+    List.map (fun ind -> IndRef ind) inds
diff --git a/vernac/record.mli b/vernac/record.mli
index 992da2aa..567f2b31 100644
--- a/vernac/record.mli
+++ b/vernac/record.mli
@@ -11,7 +11,6 @@
 open Names
 open Vernacexpr
 open Constrexpr
-open Globnames
 
 val primitive_flag : bool ref
 
@@ -21,15 +20,20 @@ val declare_projections :
   ?kind:Decl_kinds.definition_object_kind ->
   Id.t ->
   bool list ->
-  Universes.universe_binders ->
+  UnivNames.universe_binders ->
   Impargs.manual_implicits list ->
-  Context.Rel.t ->
+  Constr.rel_context ->
     (Name.t * bool) list * Constant.t option list
 
 val definition_structure :
-  inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic *
-  Declarations.recursivity_kind * ident_decl with_coercion * local_binder_expr list *
+  inductive_kind -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic ->
+  Declarations.recursivity_kind ->
+  (coercion_flag *
+  Names.lident *
+  universe_decl_expr option *
+  local_binder_expr list *
   (local_decl_expr with_instance with_priority with_notation) list *
-  Id.t * constr_expr option -> global_reference
+  Id.t * constr_expr option) list ->
+  GlobRef.t list
 
-val declare_existing_class : global_reference -> unit
+val declare_existing_class : GlobRef.t -> unit
diff --git a/vernac/search.ml b/vernac/search.ml
index a2a4fb40..e8ccec11 100644
--- a/vernac/search.ml
+++ b/vernac/search.ml
@@ -22,8 +22,8 @@ open Nametab
 
 module NamedDecl = Context.Named.Declaration
 
-type filter_function = global_reference -> env -> constr -> bool
-type display_function = global_reference -> env -> constr -> unit
+type filter_function = GlobRef.t -> env -> constr -> bool
+type display_function = GlobRef.t -> env -> constr -> unit
 
 (* This option restricts the output of [SearchPattern ...],
 [SearchAbout ...], etc. to the names of the symbols matching the
@@ -61,7 +61,7 @@ let iter_named_context_name_type f =
   List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl))
 
 (* General search over hypothesis of a goal *)
-let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
+let iter_hypothesis glnum (fn : GlobRef.t -> 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
@@ -69,7 +69,7 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
   iter_named_context_name_type iter_hyp pfctxt
 
 (* General search over declarations *)
-let iter_declarations (fn : global_reference -> env -> constr -> unit) =
+let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) =
   let env = Global.env () in
   let iter_obj (sp, kn) lobj = match object_tag lobj with
   | "VARIABLE" ->
@@ -117,8 +117,7 @@ module ConstrPriority = struct
 
   (* The priority is memoised here. Because of the very localised use
      of this module, it is not worth it making a convenient interface. *)
-  type t =
-    Globnames.global_reference * Environ.env * Constr.t * priority
+  type t = GlobRef.t * Environ.env * Constr.t * priority
   and priority = int
 
   module ConstrSet = CSet.Make(Constr)
@@ -216,7 +215,7 @@ 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 (EConstr.of_constr typ)
+  Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ)
 | GlobSearchString s ->
   String.string_contains ~where:(name_of_reference gr) ~what:s
 
@@ -227,7 +226,7 @@ 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 Evd.empty (* FIXME *) (EConstr.of_constr typ) &&
+    pattern_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) &&
     blacklist_filter ref env typ
   in
   let iter ref env typ =
@@ -251,8 +250,8 @@ let search_rewrite 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 pat1 ref env Evd.empty (* FIXME *) (EConstr.of_constr typ) ||
-       pattern_filter pat2 ref env Evd.empty (EConstr.of_constr typ)) &&
+    (pattern_filter pat1 ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) ||
+       pattern_filter pat2 ref env (Evd.from_env env) (EConstr.of_constr typ)) &&
     blacklist_filter ref env typ
   in
   let iter ref env typ =
@@ -266,7 +265,7 @@ 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 Evd.empty (* FIXME *) (EConstr.of_constr typ) &&
+    head_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) &&
     blacklist_filter ref env typ
   in
   let iter ref env typ =
@@ -330,12 +329,12 @@ let interface_search =
       toggle (Str.string_match regexp id 0) flag
     in
     let match_type (pat, flag) =
-      toggle (Constr_matching.is_matching env Evd.empty pat (EConstr.of_constr constr)) flag
+      toggle (Constr_matching.is_matching env (Evd.from_env env) pat (EConstr.of_constr constr)) flag
     in
     let match_subtype (pat, flag) =
       toggle
         (Constr_matching.is_matching_appsubterm ~closed:false 
-	   env Evd.empty pat (EConstr.of_constr constr)) flag
+           env (Evd.from_env env) pat (EConstr.of_constr constr)) flag
     in
     let match_module (mdl, flag) =
       toggle (Libnames.is_dirpath_prefix_of mdl path) flag
diff --git a/vernac/search.mli b/vernac/search.mli
index a1fb7ed3..0dc82c1c 100644
--- a/vernac/search.mli
+++ b/vernac/search.mli
@@ -12,7 +12,6 @@ open Names
 open Constr
 open Environ
 open Pattern
-open Globnames
 
 (** {6 Search facilities. } *)
 
@@ -20,8 +19,8 @@ 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
+type filter_function = GlobRef.t -> env -> constr -> bool
+type display_function = GlobRef.t -> env -> constr -> unit
 
 (** {6 Generic filter functions} *)
 
diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml
index 1d720330..f842ca5e 100644
--- a/vernac/topfmt.ml
+++ b/vernac/topfmt.ml
@@ -181,6 +181,10 @@ let default_tag_map () = let open Terminal in [
   ; "tactic.keyword"   , make ~bold:true ()
   ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN ()
   ; "tactic.string"    , make ~fg_color:`LIGHT_RED ()
+  ; "diff.added"       , make ~bg_color:(`RGB(0,141,0)) ~underline:true ()
+  ; "diff.removed"     , make ~bg_color:(`RGB(170,0,0)) ~underline:true ()
+  ; "diff.added.bg"    , make ~bg_color:(`RGB(0,91,0)) ()
+  ; "diff.removed.bg"  , make ~bg_color:(`RGB(91,0,0)) ()
   ]
 
 let tag_map = ref CString.Map.empty
@@ -198,72 +202,103 @@ let parse_color_config file =
 
 let dump_tags () = CString.Map.bindings !tag_map
 
+let empty = Terminal.make ()
+let default_style = Terminal.reset_style
+
+let get_style tag =
+  try CString.Map.find tag !tag_map
+  with Not_found -> empty;;
+
+let get_open_seq tags =
+  let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in
+  Terminal.eval (Terminal.diff default_style style);;
+
+let get_close_seq tags =
+  let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in
+  Terminal.eval (Terminal.diff style default_style);;
+
+let diff_tag_stack = ref []  (* global, just like std_ft *)
+
 (** Not thread-safe. We should put a lock somewhere if we print from
     different threads. Do we? *)
 let make_style_stack () =
   (** Default tag is to reset everything *)
-  let empty = Terminal.make () in
-  let default_tag = Terminal.({
-      fg_color = Some `DEFAULT;
-      bg_color = Some `DEFAULT;
-      bold = Some false;
-      italic = Some false;
-      underline = Some false;
-      negative = Some false;
-      prefix = None;
-      suffix = None;
-    })
-  in
   let style_stack = ref [] in
   let peek () = match !style_stack with
-  | []      -> default_tag  (** Anomalous case, but for robustness *)
+  | []      -> default_style  (** Anomalous case, but for robustness *)
   | st :: _ -> st
   in
-  let push tag =
-    let style =
-      try CString.Map.find tag !tag_map
-      with | Not_found -> empty
-    in
-    (** Use the merging of the latest tag and the one being currently pushed.
-    This may be useful if for instance the latest tag changes the background and
-    the current one the foreground, so that the two effects are additioned. *)
+  let open_tag tag =
+    let (tpfx, ttag) = split_tag tag in
+    if tpfx = end_pfx then "" else
+      let style = get_style ttag in
+    (** Merge the current settings and the style being pushed.  This allows
+    restoring the previous settings correctly in a pop when both set the same
+    attribute.  Example: current settings have red FG, the pushed style has
+    green FG.  When popping the style, we should set red FG, not default FG. *)
     let style = Terminal.merge (peek ()) style in
+    let diff = Terminal.diff (peek ()) style in
     style_stack := style :: !style_stack;
-    Terminal.eval style
+    if tpfx = start_pfx then diff_tag_stack := ttag :: !diff_tag_stack;
+    Terminal.eval diff
   in
-  let pop _ = match !style_stack with
-  | []       -> (** Something went wrong, we fallback *)
-                Terminal.eval default_tag
-  | _ :: rem -> style_stack := rem;
-                Terminal.eval (peek ())
+  let close_tag tag =
+    let (tpfx, _) = split_tag tag in
+      if tpfx = start_pfx then "" else begin
+        if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []);
+        match !style_stack with
+        | []       -> (** Something went wrong, we fallback *)
+                      Terminal.eval default_style
+        | cur :: rem -> style_stack := rem;
+                      if cur = (peek ()) then "" else
+                        if rem = [] then Terminal.reset else
+                          Terminal.eval (Terminal.diff cur (peek ()))
+      end
   in
   let clear () = style_stack := [] in
-  push, pop, clear
+  open_tag, close_tag, clear
 
 let make_printing_functions () =
-  let empty = Terminal.make () in
   let print_prefix ft tag =
-    let style =
-      try CString.Map.find tag !tag_map
-      with | Not_found -> empty
-    in
-    match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> ()
-  in
+    let (tpfx, ttag) = split_tag tag in
+    if tpfx <> end_pfx then
+      let style = get_style ttag in
+      match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in
+
   let print_suffix ft tag =
-    let style =
-      try CString.Map.find tag !tag_map
-      with | Not_found -> empty
-    in
-    match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> ()
-  in
+    let (tpfx, ttag) = split_tag tag in
+    if tpfx <> start_pfx then
+      let style = get_style ttag in
+      match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in
+
   print_prefix, print_suffix
 
+let init_output_fns () =
+  let reopen_highlight = ref "" in
+  let open Format in
+  let fns = Format.pp_get_formatter_out_functions !std_ft () in
+  let newline () =
+    if !diff_tag_stack <> [] then begin
+      let close = get_close_seq !diff_tag_stack in
+      fns.out_string close 0 (String.length close);
+      reopen_highlight := get_open_seq (List.rev !diff_tag_stack);
+    end;
+    fns.out_string "\n" 0 1 in
+  let string s off n =
+    if !reopen_highlight <> ""  && String.trim (String.sub s off n) <> "" then begin
+      fns.out_string !reopen_highlight 0 (String.length !reopen_highlight);
+      reopen_highlight := ""
+    end;
+    fns.out_string s off n in
+  let new_fns = { fns with out_string = string; out_newline = newline } in
+  Format.pp_set_formatter_out_functions !std_ft new_fns;;
+
 let init_terminal_output ~color =
-  let push_tag, pop_tag, clear_tag = make_style_stack () in
+  let open_tag, close_tag, clear_tag = make_style_stack () in
   let print_prefix, print_suffix = make_printing_functions () in
   let tag_handler ft = {
-    Format.mark_open_tag   = push_tag;
-    Format.mark_close_tag  = pop_tag;
+    Format.mark_open_tag   = open_tag;
+    Format.mark_close_tag  = close_tag;
     Format.print_open_tag  = print_prefix ft;
     Format.print_close_tag = print_suffix ft;
   } in
@@ -271,6 +306,7 @@ let init_terminal_output ~color =
     (* Use 0-length markers *)
     begin
       std_logger_cleanup := clear_tag;
+      init_output_fns ();
       Format.pp_set_mark_tags !std_ft true;
       Format.pp_set_mark_tags !err_ft true
     end
@@ -291,6 +327,14 @@ let init_terminal_output ~color =
 let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning
 
 (* This is specific to the toplevel *)
+
+type execution_phase =
+  | ParsingCommandLine
+  | Initialization
+  | LoadingPrelude
+  | LoadingRcFile
+  | InteractiveLoop
+
 let pr_loc loc =
     let fname = loc.Loc.fname in
     match fname with
@@ -303,13 +347,28 @@ let pr_loc loc =
 	   int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++
 	   str":")
 
-let print_err_exn ?extra any =
+let pr_phase ?loc phase =
+  match phase, loc with
+  | LoadingRcFile, loc ->
+     (* For when all errors go through feedback:
+     str "While loading rcfile:" ++
+     Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc *)
+     Option.map pr_loc loc
+  | LoadingPrelude, loc ->
+     Some (str "While loading initial state:" ++ Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc)
+  | _, Some loc -> Some (pr_loc loc)
+  | ParsingCommandLine, _
+  | Initialization, _ -> None
+  | InteractiveLoop, _ ->
+     (* Note: interactive messages such as "foo is defined" are not located *)
+     None
+
+let print_err_exn phase any =
   let (e, info) = CErrors.push any in
   let loc = Loc.get_loc info in
-  let msg_loc = Option.cata pr_loc (mt ()) loc in
-  let pre_hdr = pr_opt_no_spc (fun x -> x) extra ++ msg_loc in
+  let pre_hdr = pr_phase ?loc phase in
   let msg = CErrors.iprint (e, info) ++ fnl () in
-  std_logger ~pre_hdr Feedback.Error msg
+  std_logger ?pre_hdr Feedback.Error msg
 
 let with_output_to_file fname func input =
   let channel = open_out (String.concat "." [fname; "out"]) in
diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli
index 579b456a..73dcb006 100644
--- a/vernac/topfmt.mli
+++ b/vernac/topfmt.mli
@@ -53,8 +53,17 @@ val init_terminal_output : color:bool -> unit
 (** Error printing *)
 (* To be deprecated when we can fully move to feedback-based error
    printing. *)
+
+type execution_phase =
+  | ParsingCommandLine
+  | Initialization
+  | LoadingPrelude
+  | LoadingRcFile
+  | InteractiveLoop
+
 val pr_loc : Loc.t -> Pp.t
-val print_err_exn : ?extra:Pp.t -> exn -> unit
+val pr_phase : ?loc:Loc.t -> execution_phase -> Pp.t option
+val print_err_exn : execution_phase -> exn -> unit
 
 (** [with_output_to_file file f x] executes [f x] with logging
     redirected to a file [file] *)
diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib
index f001b572..356951b6 100644
--- a/vernac/vernac.mllib
+++ b/vernac/vernac.mllib
@@ -1,10 +1,18 @@
+Vernacexpr
+Pvernac
+G_vernac
+G_proofs
 Vernacprop
-Proof_using
-Lemmas
 Himsg
 ExplainErr
-Class
 Locality
+Egramml
+Vernacinterp
+Ppvernac
+Proof_using
+Lemmas
+Class
+Egramcoq
 Metasyntax
 Auto_ind_decl
 Search
@@ -20,7 +28,8 @@ Classes
 Record
 Assumptions
 Vernacstate
-Vernacinterp
 Mltop
 Topfmt
 Vernacentries
+
+Misctypes
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index fceb0bf3..f7ba3053 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -29,7 +29,6 @@ open Decl_kinds
 open Constrexpr
 open Redexpr
 open Lemmas
-open Misctypes
 open Locality
 open Vernacinterp
 
@@ -184,29 +183,27 @@ let print_modules () =
   pr_vertical_list DirPath.print only_loaded
 
 
-let print_module r =
-  let qid = qualid_of_reference r in
+let print_module qid =
   try
-    let globdir = Nametab.locate_dir qid.v in
+    let globdir = Nametab.locate_dir qid in
       match globdir with
           DirModule { obj_dir; obj_mp; _ } ->
           Printmod.print_module (Printmod.printable_body obj_dir) obj_mp
 	| _ -> raise Not_found
   with
-    Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid.v)
+    Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid)
 
-let print_modtype r =
-  let qid = qualid_of_reference r in
+let print_modtype qid =
   try
-    let kn = Nametab.locate_modtype qid.v in
+    let kn = Nametab.locate_modtype qid in
     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.v in
+      let mp = Nametab.locate_module qid in
       Printmod.print_module false mp
     with Not_found ->
-      user_err (str"Unknown Module Type or Module " ++ pr_qualid qid.v)
+      user_err (str"Unknown Module Type or Module " ++ pr_qualid qid)
 
 let print_namespace ns =
   let ns = List.rev (Names.DirPath.repr ns) in
@@ -266,15 +263,13 @@ let print_namespace ns =
   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 = Constant.user c in
-      if matches (KerName.modpath kn) then
-        acc++fnl()++hov 2 (print_constant kn body)
-      else
-        acc
-    ) constants (str"")
+    Environ.fold_constants (fun c body acc ->
+        let kn = Constant.user c in
+        if matches (KerName.modpath kn)
+        then acc++fnl()++hov 2 (print_constant kn body)
+        else acc)
+      (Global.env ()) (str"")
   in
   (print_list Id.print ns)++str":"++fnl()++constants_in_namespace
 
@@ -368,33 +363,32 @@ let msg_found_library = function
   | Library.LibInPath, fulldir, file ->
     hov 0 (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file)
 
-let err_unmapped_library ?loc ?from qid =
+let err_unmapped_library ?from qid =
   let dir = fst (repr_qualid qid) in
   let prefix = match from with
   | None -> str "."
   | Some from ->
     str " and prefix " ++ DirPath.print from ++ str "."
   in
-  user_err ?loc
+  user_err ?loc:qid.CAst.loc
     ~hdr:"locate_library"
     (strbrk "Cannot find a physical path bound to logical path matching suffix " ++
        DirPath.print dir ++ prefix)
 
-let err_notfound_library ?loc ?from qid =
+let err_notfound_library ?from qid =
   let prefix = match from with
   | None -> str "."
   | Some from ->
     str " with prefix " ++ DirPath.print from ++ str "."
   in
-  user_err ?loc ~hdr:"locate_library"
+  user_err ?loc:qid.CAst.loc ~hdr:"locate_library"
      (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix)
 
-let print_located_library r =
-  let {loc;v=qid} = qualid_of_reference r in
+let print_located_library qid =
   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
+    | Library.LibUnmappedDir -> err_unmapped_library qid
+    | Library.LibNotFound -> err_notfound_library qid
 
 let smart_global r =
   let gr = Smartlocate.smart_global r in
@@ -437,6 +431,10 @@ let vernac_notation ~atts =
   let local = enforce_module_locality atts.locality in
   Metasyntax.add_notation local (Global.env())
 
+let vernac_custom_entry ~atts s =
+  let local = enforce_module_locality atts.locality in
+  Metasyntax.declare_custom_entry local s
+
 (***********)
 (* Gallina *)
 
@@ -449,7 +447,7 @@ let start_proof_and_print k l hook =
         let evi = Evarutil.nf_evar_info sigma evi in
         let env = Evd.evar_filtered_env evi in
         try
-          let concl = EConstr.of_constr evi.Evd.evar_concl in
+          let concl = evi.Evd.evar_concl in
           if not (Evarutil.is_ground_env sigma env &&
                   Evarutil.is_ground_term sigma concl)
           then raise Exit;
@@ -518,7 +516,7 @@ 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 = Pfedit.by (Tactics.exact_proof c) in
-  save_proof (Vernacexpr.(Proved(Opaque,None)));
+  save_proof (Vernacexpr.(Proved(Proof_global.Opaque,None)));
   if not status then Feedback.feedback Feedback.AddedAxiom
 
 let vernac_assumption ~atts discharge kind l nl =
@@ -534,38 +532,52 @@ let vernac_assumption ~atts discharge kind l nl =
   if not status then Feedback.feedback Feedback.AddedAxiom
 
 let should_treat_as_cumulative cum poly =
-  if poly then
-    match cum with
-    | GlobalCumulativity | LocalCumulativity -> true
-    | GlobalNonCumulativity | LocalNonCumulativity -> false
-  else
-    match cum with
-    | GlobalCumulativity | GlobalNonCumulativity -> false
-    | LocalCumulativity -> 
-      user_err Pp.(str "The Cumulative prefix can only be used in a polymorphic context.")
-    | LocalNonCumulativity ->
-      user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.")
-
-let vernac_record cum k poly finite struc binders sort nameopt cfs =
+  match cum with
+  | Some VernacCumulative ->
+    if poly then true
+    else user_err Pp.(str "The Cumulative prefix can only be used in a polymorphic context.")
+  | Some VernacNonCumulative ->
+    if poly then false
+    else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.")
+  | None -> poly && Flags.is_polymorphic_inductive_cumulativity ()
+
+let uniform_inductive_parameters = ref false
+
+let should_treat_as_uniform () =
+  if !uniform_inductive_parameters
+  then ComInductive.UniformParameters
+  else ComInductive.NonUniformParameters
+
+let vernac_record cum k poly finite records =
   let is_cumulative = should_treat_as_cumulative cum poly in
-  let const = match nameopt with
-    | None -> add_prefix "Build_" (fst (snd struc)).v
-    | Some ({v=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;v=Name id}, _) -> Dumpglob.dump_definition (make ?loc id) false "proj"
-	| _ -> ()) cfs);
-    ignore(Record.definition_structure (k,is_cumulative,poly,finite,struc,binders,cfs,const,sort))
+  let map ((coe, (id, pl)), binders, sort, nameopt, cfs) =
+    let const = match nameopt with
+    | None -> add_prefix "Build_" id.v
+    | Some lid ->
+      let () = Dumpglob.dump_definition lid false "constr" in
+      lid.v
+    in
+    let () =
+      if Dumpglob.dump () then
+        let () = Dumpglob.dump_definition id false "rec" in
+        let iter (((_, x), _), _) = match x with
+        | Vernacexpr.AssumExpr ({loc;v=Name id}, _) ->
+          Dumpglob.dump_definition (make ?loc id) false "proj"
+        | _ -> ()
+        in
+        List.iter iter cfs
+    in
+    coe, id, pl, binders, cfs, const, sort
+  in
+  let records = List.map map records in
+  ignore(Record.definition_structure k is_cumulative poly finite records)
 
 (** 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 ~atts cum lo finite indl =
-  let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in
+  let open Pp in
   if Dumpglob.dump () then
     List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) ->
       match cstrs with
@@ -575,34 +587,86 @@ let vernac_inductive ~atts cum lo finite indl =
 			 Dumpglob.dump_definition lid false "constr") cstrs
 	| _ -> () (* dumping is done by vernac_record (called below) *) )
       indl;
+  let is_record = function
+  | ((_ , _ , _ , _, RecordDecl _), _) -> true
+  | _ -> false
+  in
+  let is_constructor = function
+  | ((_ , _ , _ , _, Constructors _), _) -> true
+  | _ -> false
+  in
+  let is_defclass = match indl with
+  | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> Some (id, bl, c, l)
+  | _ -> None
+  in
+  if Option.has_some is_defclass then
+    (** Definitional class case *)
+    let (id, bl, c, l) = Option.get is_defclass in
+    let (coe, (lid, ce)) = l in
+    let coe' = if coe then Some true else None in
+    let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in
+    vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]]
+  else if List.for_all is_record indl then
+    (** Mutual record case *)
+    let check_kind ((_, _, _, kind, _), _) = match kind with
+    | Variant ->
+      user_err (str "The Variant keyword does not support syntax { ... }.")
+    | Record | Structure | Class _ | Inductive_kw | CoInductive -> ()
+    in
+    let () = List.iter check_kind indl in
+    let check_where ((_, _, _, _, _), wh) = match wh with
+    | [] -> ()
+    | _ :: _ ->
+      user_err (str "where clause not supported for records")
+    in
+    let () = List.iter check_where indl in
+    let unpack ((id, bl, c, _, decl), _) = match decl with
+    | RecordDecl (oc, fs) ->
+      (id, bl, c, oc, fs)
+    | Constructors _ -> assert false (** ruled out above *)
+    in
+    let ((_, _, _, kind, _), _) = List.hd indl in
+    let kind = match kind with Class _ -> Class false | _ -> kind in
+    let recordl = List.map unpack indl in
+    vernac_record cum kind atts.polymorphic finite recordl
+  else if List.for_all is_constructor indl then
+    (** Mutual inductive case *)
+    let check_kind ((_, _, _, kind, _), _) = match kind with
+    | (Record | Structure) ->
+      user_err (str "The Record keyword is for types defined using the syntax { ... }.")
+    | Class _ ->
+      user_err (str "Inductive classes not supported")
+    | Variant | Inductive_kw | CoInductive -> ()
+    in
+    let () = List.iter check_kind indl in
+    let check_name ((na, _, _, _, _), _) = match na with
+    | (true, _) ->
+      user_err (str "Variant types do not handle the \"> Name\" \
+        syntax, which is reserved for records. Use the \":>\" \
+        syntax on constructors instead.")
+    | _ -> ()
+    in
+    let () = List.iter check_name indl in
+    let unpack (((_, id) , bl, c, _, decl), ntn) = match decl with
+    | Constructors l -> (id, bl, c, l), ntn
+    | RecordDecl _ -> assert false (* ruled out above *)
+    in
+    let indl = List.map unpack indl in
+    let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in
+    let uniform = should_treat_as_uniform () in
+    ComInductive.do_mutual_inductive indl is_cumulative atts.polymorphic lo ~uniform finite
+  else
+    user_err (str "Mixed record-inductive definitions are not allowed")
+(*
+
   match indl with
-  | [ ( _ , _ , _ ,(Record|Structure), Constructors _ ),_ ] ->
-      user_err Pp.(str "The Record keyword is for types defined using the syntax { ... }.")
-  | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] ->
-      user_err Pp.(str "The Variant keyword does not support syntax { ... }.")
-  | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] ->
-      vernac_record cum (match b with Class _ -> Class false | _ -> b)
-       atts.polymorphic finite id bl c oc fs
   | [ ( id , bl , c , Class _, Constructors [l]), [] ] ->
       let f =
         let (coe, ({loc;v=id}, ce)) = l in
 	let coe' = if coe then Some true else None in
           (((coe', AssumExpr ((make ?loc @@ Name id), ce)), None), [])
-      in vernac_record cum (Class true) atts.polymorphic finite id bl c None [f]
-  | [ ( _ , _, _, Class _, Constructors _), [] ] ->
-      user_err Pp.(str "Inductive classes not supported")
-  | [ ( id , bl , c , Class _, _), _ :: _ ] ->
-      user_err Pp.(str "where clause not supported for classes")
-  | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
-      user_err Pp.(str "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 _),_ ->
-          user_err Pp.(str "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead.")
-      | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.")
-    in
-    let indl = List.map unpack indl in
-    ComInductive.do_mutual_inductive indl is_cumulative atts.polymorphic lo finite
+      in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]]
+    *)
 
 let vernac_fixpoint ~atts discharge l =
   let local = enforce_locality_exp atts.locality discharge in
@@ -640,7 +704,7 @@ let vernac_scheme l =
 let vernac_combined_scheme lid l =
   if Dumpglob.dump () then
     (Dumpglob.dump_definition lid false "def";
-     List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ Misctypes.AN (make ?loc @@ Ident id))) l);
+     List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ AN (qualid_of_ident ?loc id))) l);
  Indschemes.do_combined_scheme lid l
 
 let vernac_universe ~atts l =
@@ -661,7 +725,7 @@ let vernac_constraint ~atts l =
 (* Modules            *)
 
 let vernac_import export refl =
-  Library.import_module export (List.map qualid_of_reference refl)
+  Library.import_module export refl
 
 let vernac_declare_module export {loc;v=id} binders_ast mty_ast =
   (* We check the state of the system (in section, in module type)
@@ -675,11 +739,11 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast =
      else (idl,ty)) binders_ast in
   let mp =
     Declaremods.declare_module Modintern.interp_module_ast
-      id binders_ast (Enforce mty_ast) []
+      id binders_ast (Declaremods.Enforce mty_ast) []
   in
   Dumpglob.dump_moddef ?loc mp "mod";
   Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared");
-  Option.iter (fun export -> vernac_import export [make @@ Ident id]) export
+  Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export
 
 let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l =
   (* We check the state of the system (in section, in module type)
@@ -704,7 +768,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt
        List.iter
          (fun (export,id) ->
            Option.iter
-             (fun export -> vernac_import export [make @@ Ident id]) export
+             (fun export -> vernac_import export [qualid_of_ident id]) export
          ) argsexport
     | _::_ ->
        let binders_ast = List.map
@@ -719,14 +783,14 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt
        Dumpglob.dump_moddef ?loc mp "mod";
        Flags.if_verbose Feedback.msg_info
 	 (str "Module " ++ Id.print id ++ str " is defined");
-       Option.iter (fun export -> vernac_import export [make @@ Ident id])
+       Option.iter (fun export -> vernac_import export [qualid_of_ident id])
          export
 
 let vernac_end_module export {loc;v=id} =
   let mp = Declaremods.end_module () in
   Dumpglob.dump_modref ?loc mp "mod";
   Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined");
-  Option.iter (fun export -> vernac_import export [make ?loc @@ Ident id]) export
+  Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export
 
 let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l =
   if Lib.sections_are_opened () then
@@ -751,7 +815,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l =
        List.iter
          (fun (export,id) ->
            Option.iter
-             (fun export -> vernac_import export [make ?loc @@ Ident id]) export
+             (fun export -> vernac_import export [qualid_of_ident ?loc id]) export
          ) argsexport
 
     | _ :: _ ->
@@ -813,22 +877,20 @@ let warn_require_in_section =
 
 let vernac_require from import qidl =
   if Lib.sections_are_opened () then warn_require_in_section ();
-  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.v in
+    let (hd, tl) = Libnames.repr_qualid from in
     Some (Libnames.add_dirpath_suffix hd tl)
   in
-  let locate {loc;v=qid} =
+  let locate qid =
     try
       let warn = not !Flags.quiet 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
+      | Library.LibUnmappedDir -> err_unmapped_library ?from:root qid
+      | Library.LibNotFound -> err_notfound_library ?from:root qid
   in
   let modrefl = List.map locate qidl in
   if Dumpglob.dump () then
@@ -858,7 +920,7 @@ let vernac_identity_coercion ~atts id qids qidt =
 
 let vernac_instance ~atts abst sup inst props pri =
   let global = not (make_section_locality atts.locality) in
-  Dumpglob.dump_constraint inst false "inst";
+  Dumpglob.dump_constraint (fst (pi1 inst)) false "inst";
   let program_mode = Flags.is_program_mode () in
   ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri)
 
@@ -912,7 +974,7 @@ let vernac_set_used_variables e =
     if List.is_empty to_clear then (p, ())
     else
       let tac = Tactics.clear to_clear in
-      fst (Pfedit.solve SelectAll None tac p), ()
+      fst (Pfedit.solve Goal_select.SelectAll None tac p), ()
   end
 
 (*****************************)
@@ -980,7 +1042,7 @@ let vernac_remove_hints ~atts dbs ids =
 
 let vernac_hints ~atts lb h =
   let local = enforce_module_locality atts.locality in
-  Hints.add_hints local lb (Hints.interp_hints atts.polymorphic h)
+  Hints.add_hints ~local lb (Hints.interp_hints atts.polymorphic h)
 
 let vernac_syntactic_definition ~atts lid x y =
   Dumpglob.dump_definition lid false "syndef";
@@ -1134,15 +1196,16 @@ let vernac_arguments ~atts reference args more_implicits nargs_for_red flags =
   let names = rename prev_names names in
   let renaming_specified = Option.has_some !example_renaming in
 
-  if !rename_flag_required && not rename_flag then
-    user_err ~hdr:"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 " ++ Name.print o ++
-            str " renamed to " ++ Name.print n ++ str ".");
+  if !rename_flag_required && not rename_flag then begin
+    let msg =
+      match !example_renaming with
+      | None ->
+        strbrk "To rename arguments the \"rename\" flag must be specified."
+      | Some (o,n) ->
+        strbrk "Flag \"rename\" expected to rename " ++ Name.print o ++
+        strbrk " into " ++ Name.print n ++ str "."
+    in user_err ~hdr:"vernac_declare_arguments" msg
+  end;
 
   let duplicate_names =
     List.duplicates Name.equal (List.filter ((!=) Anonymous) names)
@@ -1271,7 +1334,7 @@ let vernac_reserve bl =
 
 let vernac_generalizable ~atts =
   let local = make_non_locality atts.locality in
-  Implicit_quantifiers.declare_generalizable local
+  Implicit_quantifiers.declare_generalizable ~local
 
 let _ =
   declare_bool_option
@@ -1420,6 +1483,14 @@ let _ =
       optwrite = Flags.make_polymorphic_inductive_cumulativity }
 
 let _ =
+  declare_bool_option
+    { optdepr  = false;
+      optname  = "Uniform inductive parameters";
+      optkey   = ["Uniform"; "Inductive"; "Parameters"];
+      optread  = (fun () -> !uniform_inductive_parameters);
+      optwrite = (fun b -> uniform_inductive_parameters := b) }
+
+let _ =
   declare_int_option
     { optdepr  = false;
       optname  = "the level of inlining during functor application";
@@ -1434,8 +1505,8 @@ let _ =
     { optdepr  = false;
       optname  = "kernel term sharing";
       optkey   = ["Kernel"; "Term"; "Sharing"];
-      optread  = (fun () -> !CClosure.share);
-      optwrite = (fun b -> CClosure.share := b) }
+      optread  = (fun () -> (Global.typing_flags ()).Declarations.share_reduction);
+      optwrite = (fun b -> Global.set_reduction_sharing b) }
 
 let _ =
   declare_bool_option
@@ -1468,22 +1539,22 @@ let _ =
       optkey   = ["Printing";"Universes"];
       optread  = (fun () -> !Constrextern.print_universes);
       optwrite = (fun b -> Constrextern.print_universes:=b) }
-     
+
 let _ =
   declare_bool_option
     { optdepr  = false;
       optname  = "dumping bytecode after compilation";
       optkey   = ["Dump";"Bytecode"];
-      optread  = Flags.get_dump_bytecode;
-      optwrite = Flags.set_dump_bytecode }
+      optread  = (fun () -> !Cbytegen.dump_bytecode);
+      optwrite = (:=) Cbytegen.dump_bytecode }
 
 let _ =
   declare_bool_option
     { optdepr  = false;
       optname  = "dumping VM lambda code after compilation";
       optkey   = ["Dump";"Lambda"];
-      optread  = Flags.get_dump_lambda;
-      optwrite = Flags.set_dump_lambda }
+      optread  = (fun () -> !Clambda.dump_lambda);
+      optwrite = (:=) Clambda.dump_lambda }
 
 let _ =
   declare_bool_option
@@ -1614,7 +1685,7 @@ let get_current_context_of_args = function
 
 let query_command_selector ?loc = function
   | None -> None
-  | Some (SelectNth n) -> Some n
+  | Some (Goal_select.SelectNth n) -> Some n
   | _ -> user_err ?loc ~hdr:"query_command_selector"
       (str "Query commands only support the single numbered goal selector.")
 
@@ -1622,17 +1693,16 @@ let vernac_check_may_eval ~atts redexp glopt rc =
   let glopt = query_command_selector ?loc:atts.loc glopt in
   let (sigma, env) = get_current_context_of_args glopt in
   let sigma, c = interp_open_constr env sigma rc in
-  let c = EConstr.Unsafe.to_constr c 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 sigma = Evd.minimize_universes sigma in
   let uctx = Evd.universe_context_set sigma in
   let env = Environ.push_context_set uctx (Evarutil.nf_env_evar sigma env) in
-  let c = nf c in
   let j =
-    if Evarutil.has_undefined_evars sigma (EConstr.of_constr c) then
-      Evarutil.j_nf_evar sigma (Retyping.get_judgment_of env sigma (EConstr.of_constr c))
+    if Evarutil.has_undefined_evars sigma c then
+      Evarutil.j_nf_evar sigma (Retyping.get_judgment_of env sigma c)
     else
+      let c = EConstr.to_constr sigma c in
       (* OK to call kernel which does not support evars *)
       Termops.on_judgment EConstr.of_constr (Arguments_renaming.rename_typing env c)
   in
@@ -1656,7 +1726,9 @@ let vernac_check_may_eval ~atts redexp glopt rc =
 
 let vernac_declare_reduction ~atts s r =
   let local = make_locality atts.locality in
-  declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r))
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  declare_red_expr local s (snd (Hook.get f_interp_redexp env sigma r))
 
   (* The same but avoiding the current goal context if any *)
 let vernac_global_check c =
@@ -1690,10 +1762,10 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt =
     let glnumopt = query_command_selector ?loc glopt in
     let gl,id =
       match glnumopt, ref_or_by_not.v with
-      | None,AN {v=Ident id} -> (* goal number not given, catch any failure *)
-	 (try get_nth_goal 1,id with _ -> raise NoHyp)
-      | Some n,AN {v=Ident id} ->  (* goal number given, catch if wong *)
-	 (try get_nth_goal n,id
+      | None,AN qid when qualid_is_ident qid -> (* goal number not given, catch any failure *)
+         (try get_nth_goal 1, qualid_basename qid with _ -> raise NoHyp)
+      | Some n,AN qid when qualid_is_ident qid ->  (* goal number given, catch if wong *)
+         (try get_nth_goal n, qualid_basename qid
 	  with
 	    Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs"
                           (str "No such goal: " ++ int n ++ str "."))
@@ -1746,7 +1818,7 @@ let vernac_print ~atts env sigma =
        else str"There may remain asynchronous universe constraints"
      in
      begin match dst with
-     | None -> UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining
+     | None -> UGraph.pr_universes UnivNames.pr_with_global_universes univ ++ pr_remaining
      | Some s -> dump_universes_gen univ s
      end
   | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r)
@@ -1774,11 +1846,10 @@ let vernac_print ~atts env sigma =
       Printer.pr_assumptionset env sigma nassums
   | PrintStrategy r -> print_strategy r
 
-let global_module r =
-  let {loc;v=qid} = qualid_of_reference r in
+let global_module qid =
   try Nametab.full_name_module qid
   with Not_found ->
-    user_err ?loc ~hdr:"global_module"
+    user_err ?loc:qid.CAst.loc ~hdr:"global_module"
      (str "Module/section " ++ pr_qualid qid ++ str " not found.")
 
 let interp_search_restriction = function
@@ -1916,9 +1987,10 @@ let vernac_subproof gln =
   Proof_global.simple_with_current_proof (fun _ p ->
     match gln with
     | None -> Proof.focus subproof_cond () 1 p
-    | Some (SelectNth n) -> Proof.focus subproof_cond () n p
+    | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p
+    | Some (Goal_select.SelectId id) -> Proof.focus_id subproof_cond () id p
     | _ -> user_err ~hdr:"bracket_selector"
-             (str "Brackets only support the single numbered goal selector."))
+             (str "Brackets do not support multi-goal selectors."))
 
 let vernac_end_subproof () =
   Proof_global.simple_with_current_proof (fun _ p ->
@@ -1974,7 +2046,7 @@ let vernac_load interp fname =
     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
+    match Pcoq.Entry.parse Pvernac.main_entry po with
       | Some x -> x
       | None -> raise End_of_input) in
   let fname =
@@ -1983,7 +2055,7 @@ let vernac_load interp fname =
   let input =
     let longfname = Loadpath.locate_file fname in
     let in_chan = open_utf8_file_in longfname in
-    Pcoq.Gram.parsable ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in
+    Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in
   begin
     try while true do interp (snd (parse_sentence input)) done
     with End_of_input -> ()
@@ -2009,10 +2081,6 @@ let interp ?proof ~atts ~st c =
   | VernacRestart     -> CErrors.user_err  (str "Restart cannot be used through the Load command")
   | VernacUndo _      -> CErrors.user_err  (str "Undo cannot be used through the Load command")
   | VernacUndoTo _    -> CErrors.user_err  (str "UndoTo cannot be used through the Load command")
-  | VernacBacktrack _ -> CErrors.user_err  (str "Backtrack cannot be used through the Load command")
-
-  (* Toplevel control *)
-  | VernacToplevelControl e -> raise e
 
   (* Resetting *)
   | VernacResetName _  -> anomaly (str "VernacResetName not handled by Stm.")
@@ -2029,12 +2097,13 @@ let interp ?proof ~atts ~st c =
   | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
   | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
   | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s)
-  | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope ~atts qid scl
   | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc
   | VernacNotation (c,infpl,sc) ->
       vernac_notation ~atts c infpl sc
   | VernacNotationAddFormat(n,k,v) ->
       Metasyntax.add_notation_extra_printing_rule n k v
+  | VernacDeclareCustomEntry s ->
+      vernac_custom_entry ~atts s
 
   (* Gallina *)
   | VernacDefinition ((discharge,kind),lid,d) ->
@@ -2044,7 +2113,7 @@ let interp ?proof ~atts ~st c =
   | VernacExactProof c -> vernac_exact_proof c
   | VernacAssumption ((discharge,kind),nl,l) ->
       vernac_assumption ~atts discharge kind l nl
-  | VernacInductive (cum, priv,finite,l) -> vernac_inductive ~atts cum priv finite l
+  | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l
   | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l
   | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l
   | VernacScheme l -> vernac_scheme l
@@ -2103,8 +2172,6 @@ let interp ?proof ~atts ~st c =
       vernac_hints ~atts dbnames hints
   | VernacSyntacticDefinition (id,c,b) ->
       vernac_syntactic_definition ~atts id c b
-  | VernacDeclareImplicits (qid,l) ->
-      vernac_declare_implicits ~atts qid l
   | VernacArguments (qid, args, more_implicits, nargs, flags) ->
       vernac_arguments ~atts qid args more_implicits nargs flags
   | VernacReserve bl -> vernac_reserve bl
@@ -2165,6 +2232,7 @@ let check_vernac_supports_locality c l =
   | Some _, (
       VernacOpenCloseScope _
     | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _
+    | VernacDeclareCustomEntry _
     | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
     | VernacAssumption _ | VernacStartTheoremProof _
     | VernacCoercion _ | VernacIdentityCoercion _
@@ -2172,7 +2240,7 @@ let check_vernac_supports_locality c l =
     | VernacDeclareMLModule _
     | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
     | VernacSyntacticDefinition _
-    | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _
+    | VernacArguments _
     | VernacGeneralizable _
     | VernacSetOpacity _ | VernacSetStrategy _
     | VernacSetOption _ | VernacUnsetOption _
@@ -2255,37 +2323,67 @@ let with_fail st b f =
       | HasNotFailed ->
           user_err ~hdr:"Fail" (str "The command has not failed!")
       | HasFailed msg ->
-          if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info
+          if not !Flags.quiet || !Flags.test_mode then Feedback.msg_info
             (str "The command has indeed failed with message:" ++ fnl () ++ msg)
       | _ -> assert false
   end
 
+let attributes_of_flags f atts =
+  let assert_empty k v =
+    if v <> VernacFlagEmpty
+    then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments")
+  in
+  List.fold_left
+    (fun (polymorphism, atts) (k, v) ->
+       match k with
+       | "program" when not atts.program ->
+         assert_empty k v;
+         (polymorphism, { atts with program = true })
+       | "program" ->
+         user_err Pp.(str "Program mode specified twice")
+       | "polymorphic" when polymorphism = None ->
+         assert_empty k v;
+         (Some true, atts)
+       | "monomorphic" when polymorphism = None ->
+         assert_empty k v;
+         (Some false, atts)
+       | ("polymorphic" | "monomorphic") ->
+         user_err Pp.(str "Polymorphism specified twice")
+       | "local" when Option.is_empty atts.locality ->
+         assert_empty k v;
+         (polymorphism, { atts with locality = Some true })
+       | "global" when Option.is_empty atts.locality ->
+         assert_empty k v;
+         (polymorphism, { atts with locality = Some false })
+       | ("local" | "global") ->
+         user_err Pp.(str "Locality specified twice")
+       | "deprecated" when Option.is_empty atts.deprecated ->
+           begin match v with
+             | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ]
+             | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] ->
+               let since = Some since and note = Some note in
+               (polymorphism, { atts with deprecated = Some (mk_deprecation ~since ~note ()) })
+             | VernacFlagList [ "since", VernacFlagLeaf since ] ->
+               let since = Some since in
+               (polymorphism, { atts with deprecated = Some (mk_deprecation ~since ()) })
+             | VernacFlagList [ "note", VernacFlagLeaf note ] ->
+               let note = Some note in
+               (polymorphism, { atts with deprecated = Some (mk_deprecation ~note ()) })
+             |  _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute")
+           end
+       | "deprecated" ->
+         user_err Pp.(str "Deprecation specified twice")
+       | _ -> user_err Pp.(str "Unknown attribute " ++ str k)
+    )
+    (None, atts)
+    f
+
 let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} =
   let orig_univ_poly = Flags.is_universe_polymorphism () in
   let orig_program_mode = Flags.is_program_mode () in
-  let flags f atts =
-    List.fold_left
-      (fun (polymorphism, atts) f ->
-         match f with
-         | VernacProgram when not atts.program ->
-           (polymorphism, { atts with program = true })
-         | VernacProgram ->
-           user_err Pp.(str "Program mode specified twice")
-         | VernacPolymorphic b when polymorphism = None ->
-           (Some b, atts)
-         | VernacPolymorphic _ ->
-           user_err Pp.(str "Polymorphism specified twice")
-         | VernacLocal b when Option.is_empty atts.locality ->
-           (polymorphism, { atts with locality = Some b })
-         | VernacLocal _ ->
-           user_err Pp.(str "Locality specified twice")
-      )
-      (None, atts)
-      f
-  in
   let rec control = function
   | VernacExpr (f, v) ->
-    let (polymorphism, atts) = flags f { loc; locality = None; polymorphic = false; program = orig_program_mode; } in
+    let (polymorphism, atts) = attributes_of_flags f (mk_atts ~program:orig_program_mode ()) in
     aux ~polymorphism ~atts v
   | VernacFail v -> with_fail st true (fun () -> control v)
   | VernacTimeout (n,v) ->
@@ -2347,3 +2445,121 @@ let interp ?verbosely ?proof ~st cmd =
     let exn = CErrors.push exn in
     Vernacstate.invalidate_cache ();
     iraise exn
+
+(** VERNAC EXTEND registering *)
+
+open Genarg
+open Extend
+
+type classifier = Genarg.raw_generic_argument list -> vernac_classification
+
+type (_, _) ty_sig =
+| TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig
+| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig
+| TyNonTerminal :
+  string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig
+
+type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml
+
+let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND")
+
+let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function
+| TyNil -> fun f args ->
+  begin match args with
+  | [] -> f
+  | _ :: _ -> type_error ()
+  end
+| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args
+| TyNonTerminal (_, tu, ty) -> fun f args ->
+  begin match args with
+  | [] -> type_error ()
+  | Genarg.GenArg (Rawwit tag, v) :: args ->
+    match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with
+    | None -> type_error ()
+    | Some Refl -> untype_classifier ty (f v) args
+  end
+
+(** Stupid GADTs forces us to duplicate the definition just for typing *)
+let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function
+| TyNil -> fun f args ->
+  begin match args with
+  | [] -> f
+  | _ :: _ -> type_error ()
+  end
+| TyTerminal (_, ty) -> fun f args -> untype_command ty f args
+| TyNonTerminal (_, tu, ty) -> fun f args ->
+  begin match args with
+  | [] -> type_error ()
+  | Genarg.GenArg (Rawwit tag, v) :: args ->
+    match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with
+    | None -> type_error ()
+    | Some Refl -> untype_command ty (f v) args
+  end
+
+let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = function
+| TUlist1 l -> Alist1 (untype_user_symbol l)
+| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s))
+| TUlist0 l -> Alist0 (untype_user_symbol l)
+| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s))
+| TUopt o -> Aopt (untype_user_symbol o)
+| TUentry a -> Aentry (Pcoq.genarg_grammar (ExtraArg a))
+| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (ExtraArg a), string_of_int i)
+
+let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function
+| TyNil -> []
+| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty
+| TyNonTerminal (id, tu, ty) ->
+  let t = Option.map (fun _ -> rawwit (Egramml.proj_symbol tu)) id in
+  let symb = untype_user_symbol tu in
+  Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty
+
+let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol
+
+let classifiers : classifier array String.Map.t ref = ref String.Map.empty
+
+let get_vernac_classifier (name, i) args =
+  (String.Map.find name !classifiers).(i) args
+
+let declare_vernac_classifier name f =
+  classifiers := String.Map.add name f !classifiers
+
+let vernac_extend ~command ?classifier ?entry ext =
+  let get_classifier (TyML (_, ty, _, cl)) = match cl with
+  | Some cl -> untype_classifier ty cl
+  | None ->
+    match classifier with
+    | Some cl -> fun _ -> cl command
+    | None ->
+      let e = match entry with
+      | None -> "COMMAND"
+      | Some e -> Pcoq.Gram.Entry.name e
+      in
+      let msg = Printf.sprintf "\
+        Vernac entry \"%s\" misses a classifier. \
+        A classifier is a function that returns an expression \
+        of type vernac_classification (see Vernacexpr). You can: \n\
+        - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \
+          new vernacular command does not alter the system state;\n\
+        - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \
+          new vernacular command alters the system state but not the \
+          parser nor it starts a proof or ends one;\n\
+        - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \
+          a global function f.  The function f will be called passing\
+          \"%s\" as the only argument;\n\
+        - Add a specific classifier in each clause using the syntax:\n\
+          '[...] => [ f ] -> [...]'.\n\
+        Specific classifiers have precedence over global \
+        classifiers. Only one classifier is called."
+          command e e e command
+      in
+      CErrors.user_err (Pp.strbrk msg)
+  in
+  let cl = Array.map_of_list get_classifier ext in
+  let iter i (TyML (depr, ty, f, _)) =
+    let f = untype_command ty f in
+    let r = untype_grammar ty in
+    let () = vinterp_add depr (command, i) f in
+    Egramml.extend_vernac_command_grammar (command, i) entry r
+  in
+  let () = declare_vernac_classifier command cl in
+  List.iteri iter ext
diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli
index f6199e82..fb2a30ba 100644
--- a/vernac/vernacentries.mli
+++ b/vernac/vernacentries.mli
@@ -8,13 +8,11 @@
 (*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Misctypes
-
-val dump_global : Libnames.reference or_by_notation -> unit
+val dump_global : Libnames.qualid Constrexpr.or_by_notation -> unit
 
 (** Vernacular entries *)
 val vernac_require :
-  Libnames.reference option -> bool option -> Libnames.reference list -> unit
+  Libnames.qualid option -> bool option -> Libnames.qualid list -> unit
 
 (** The main interpretation function of vernacular expressions *)
 val interp :
@@ -40,3 +38,37 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr
   Evd.evar_map * Redexpr.red_expr) Hook.t
 
 val universe_polymorphism_option_name : string list
+
+(** Elaborate a [atts] record out of a list of flags.
+    Also returns whether polymorphism is explicitly (un)set. *)
+val attributes_of_flags : Vernacexpr.vernac_flags -> Vernacinterp.atts -> bool option * Vernacinterp.atts
+
+(** {5 VERNAC EXTEND} *)
+
+type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification
+
+type (_, _) ty_sig =
+| TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig
+| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig
+| TyNonTerminal :
+  string option *
+  ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig ->
+    ('a -> 'r, 'a -> 's) ty_sig
+
+type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml
+
+(** Wrapper to dynamically extend vernacular commands. *)
+val vernac_extend :
+  command:string ->
+  ?classifier:(string -> Vernacexpr.vernac_classification) ->
+  ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t ->
+  ty_ml list -> unit
+
+(** {5 STM classifiers} *)
+
+val get_vernac_classifier :
+  Vernacexpr.extend_name -> classifier
+
+(** Low-level API, not for casual user. *)
+val declare_vernac_classifier :
+  string -> classifier array -> unit
diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml
new file mode 100644
index 00000000..7d8595e4
--- /dev/null
+++ b/vernac/vernacexpr.ml
@@ -0,0 +1,539 @@
+(************************************************************************)
+(*         *   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)         *)
+(************************************************************************)
+
+open Names
+open Constrexpr
+open Libnames
+
+(** Vernac expressions, produced by the parser *)
+type class_rawexpr = FunClass | SortClass | RefClass of qualid or_by_notation
+
+type goal_selector = Goal_select.t =
+  | SelectAlreadyFocused [@ocaml.deprecated "Use Goal_select.SelectAlreadyFocused"]
+  | SelectNth of int [@ocaml.deprecated "Use Goal_select.SelectNth"]
+  | SelectList of (int * int) list [@ocaml.deprecated "Use Goal_select.SelectList"]
+  | SelectId of Id.t [@ocaml.deprecated "Use Goal_select.SelectId"]
+  | SelectAll [@ocaml.deprecated "Use Goal_select.SelectAll"]
+[@@ocaml.deprecated "Use Goal_select.t"]
+
+type goal_identifier = string
+type scope_name = string
+
+type goal_reference =
+  | OpenSubgoals
+  | NthGoal of int
+  | GoalId of Id.t
+
+type univ_name_list = UnivNames.univ_name_list
+[@@ocaml.deprecated "Use [UnivNames.univ_name_list]"]
+
+type printable =
+  | PrintTables
+  | PrintFullContext
+  | PrintSectionContext of qualid
+  | PrintInspect of int
+  | PrintGrammar of string
+  | PrintLoadPath of DirPath.t option
+  | PrintModules
+  | PrintModule of qualid
+  | PrintModuleType of qualid
+  | PrintNamespace of DirPath.t
+  | PrintMLLoadPath
+  | PrintMLModules
+  | PrintDebugGC
+  | PrintName of qualid or_by_notation * UnivNames.univ_name_list option
+  | PrintGraph
+  | PrintClasses
+  | PrintTypeClasses
+  | PrintInstances of qualid or_by_notation
+  | PrintCoercions
+  | PrintCoercionPaths of class_rawexpr * class_rawexpr
+  | PrintCanonicalConversions
+  | PrintUniverses of bool * string option
+  | PrintHint of qualid or_by_notation
+  | PrintHintGoal
+  | PrintHintDbName of string
+  | PrintHintDb
+  | PrintScopes
+  | PrintScope of string
+  | PrintVisibility of string option
+  | PrintAbout of qualid or_by_notation * UnivNames.univ_name_list option * Goal_select.t option
+  | PrintImplicit of qualid or_by_notation
+  | PrintAssumptions of bool * bool * qualid or_by_notation
+  | PrintStrategy of qualid or_by_notation option
+
+type search_about_item =
+  | SearchSubPattern of constr_pattern_expr
+  | SearchString of string * scope_name option
+
+type searchable =
+  | SearchPattern of constr_pattern_expr
+  | SearchRewrite of constr_pattern_expr
+  | SearchHead of constr_pattern_expr
+  | SearchAbout of (bool * search_about_item) list
+
+type locatable =
+  | LocateAny of qualid or_by_notation
+  | LocateTerm of qualid or_by_notation
+  | LocateLibrary of qualid
+  | LocateModule of qualid
+  | LocateOther of string * qualid
+  | LocateFile of string
+
+type showable =
+  | ShowGoal of goal_reference
+  | ShowProof
+  | ShowScript
+  | ShowExistentials
+  | ShowUniverses
+  | ShowProofNames
+  | ShowIntros of bool
+  | ShowMatch of qualid
+
+type comment =
+  | CommentConstr of constr_expr
+  | CommentString of string
+  | CommentInt of int
+
+type reference_or_constr = Hints.reference_or_constr =
+  | HintsReference of qualid [@ocaml.deprecated "Use Hints.HintsReference"]
+  | HintsConstr of constr_expr [@ocaml.deprecated "Use Hints.HintsConstr"]
+[@@ocaml.deprecated "Please use [Hints.reference_or_constr]"]
+
+type hint_mode = Hints.hint_mode =
+  | ModeInput [@ocaml.deprecated "Use Hints.ModeInput"]
+  | ModeNoHeadEvar [@ocaml.deprecated "Use Hints.ModeNoHeadEvar"]
+  | ModeOutput [@ocaml.deprecated "Use Hints.ModeOutput"]
+[@@ocaml.deprecated "Please use [Hints.hint_mode]"]
+
+type 'a hint_info_gen = 'a Typeclasses.hint_info_gen =
+    { hint_priority : int option; [@ocaml.deprecated "Use Typeclasses.hint_priority"]
+      hint_pattern : 'a option [@ocaml.deprecated "Use Typeclasses.hint_pattern"] }
+[@@ocaml.deprecated "Please use [Typeclasses.hint_info_gen]"]
+
+type hint_info_expr = Hints.hint_info_expr
+[@@ocaml.deprecated "Please use [Hints.hint_info_expr]"]
+
+type hints_expr = Hints.hints_expr =
+  | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsResolveIFF of bool * qualid list * int option
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsImmediate of Hints.reference_or_constr list
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsUnfold of qualid list
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsTransparency of qualid Hints.hints_transparency_target * bool
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsMode of qualid * Hints.hint_mode list
+                   [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsConstructors of qualid list
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+  | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument
+        [@ocaml.deprecated "Use the constructor in module [Hints]"]
+[@@ocaml.deprecated "Please use [Hints.hints_expr]"]
+
+type search_restriction =
+  | SearchInside of qualid list
+  | SearchOutside of qualid list
+
+type rec_flag       = bool (* true = Rec;           false = NoRec          *)
+type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
+type opacity_flag   = Proof_global.opacity_flag =
+    Opaque [@ocaml.deprecated "Use Proof_global.Opaque"]
+  | Transparent [@ocaml.deprecated "Use Proof_global.Transparent"]
+ [@ocaml.deprecated "Please use [Proof_global.opacity_flag]"]
+type coercion_flag  = bool (* true = AddCoercion    false = NoCoercion     *)
+type instance_flag  = bool option
+  (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *)
+type export_flag    = bool (* true = Export;        false = Import         *)
+type inductive_flag = Declarations.recursivity_kind
+type onlyparsing_flag = Flags.compat_version option
+ (* Some v = Parse only;  None = Print also.
+    If v<>Current, it contains the name of the coq version
+    which this notation is trying to be compatible with *)
+type locality_flag  = bool (* true = Local *)
+
+type option_value = Goptions.option_value =
+  | BoolValue of bool
+  | IntValue of int option
+  | StringValue of string
+  | StringOptValue of string option
+
+type option_ref_value =
+  | StringRefValue of string
+  | QualidRefValue of qualid
+
+(** Identifier and optional list of bound universes and constraints. *)
+
+type sort_expr = Sorts.family
+
+type definition_expr =
+  | ProveBody of local_binder_expr list * constr_expr
+  | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr
+      * constr_expr option
+
+type fixpoint_expr =
+    ident_decl * (lident option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option
+
+type cofixpoint_expr =
+    ident_decl * local_binder_expr list * constr_expr * constr_expr option
+
+type local_decl_expr =
+  | AssumExpr of lname * constr_expr
+  | DefExpr of lname * constr_expr * constr_expr option
+
+type inductive_kind = Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool (* true = definitional, false = inductive *)
+type decl_notation = lstring * constr_expr * scope_name option
+type simple_binder = lident list  * constr_expr
+type class_binder = lident * constr_expr list
+type 'a with_coercion = coercion_flag * 'a
+type 'a with_instance = instance_flag * 'a
+type 'a with_notation = 'a * decl_notation list
+type 'a with_priority = 'a * int option
+type constructor_expr = (lident * constr_expr) with_coercion
+type constructor_list_or_record_decl_expr =
+  | Constructors of constructor_expr list
+  | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list
+type inductive_expr =
+  ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind *
+    constructor_list_or_record_decl_expr
+
+type one_inductive_expr =
+  ident_decl * local_binder_expr list * constr_expr option * constructor_expr list
+
+type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr
+and typeclass_context = typeclass_constraint list
+
+type proof_expr =
+  ident_decl * (local_binder_expr list * constr_expr)
+
+type syntax_modifier =
+  | SetItemLevel of string list * Notation_term.constr_as_binder_kind option * Extend.production_level option
+  | SetLevel of int
+  | SetCustomEntry of string * int option
+  | SetAssoc of Extend.gram_assoc
+  | SetEntryType of string * Extend.simple_constr_prod_entry_key
+  | SetOnlyParsing
+  | SetOnlyPrinting
+  | SetCompatVersion of Flags.compat_version
+  | SetFormat of string * lstring
+
+type proof_end =
+  | Admitted
+  (*                         name in `Save ident` when closing goal *)
+  | Proved of Proof_global.opacity_flag * lident option
+
+type scheme =
+  | InductionScheme of bool * qualid or_by_notation * sort_expr
+  | CaseScheme of bool * qualid or_by_notation * sort_expr
+  | EqualityScheme of qualid or_by_notation
+
+type section_subset_expr =
+  | SsEmpty
+  | SsType
+  | SsSingl of lident
+  | SsCompl of section_subset_expr
+  | SsUnion of section_subset_expr * section_subset_expr
+  | SsSubstr of section_subset_expr * section_subset_expr
+  | SsFwdClose of section_subset_expr
+
+(** Extension identifiers for the VERNAC EXTEND mechanism.
+
+    {b ("Extraction", 0} indicates {b Extraction {i qualid}} command.
+
+    {b ("Extraction", 1} indicates {b Recursive Extraction {i qualid}} command.
+
+    {b ("Extraction", 2)} indicates {b Extraction "{i filename}" {i qualid{_ 1}} ... {i qualid{_ n}}} command.
+
+    {b ("ExtractionLibrary", 0)} indicates {b Extraction Library {i ident}} command.
+
+    {b ("RecursiveExtractionLibrary", 0)} indicates {b Recursive Extraction Library {i ident}} command.
+
+    {b ("SeparateExtraction", 0)} indicates {b Separate Extraction {i qualid{_ 1}} ... {i qualid{_ n}}} command.
+
+    {b ("ExtractionLanguage", 0)} indicates {b Extraction Language Ocaml} or {b Extraction Language Haskell} or {b Extraction Language Scheme} or {b Extraction Language JSON} commands.
+
+    {b ("ExtractionImplicit", 0)} indicates {b Extraction Implicit {i qualid} \[ {i ident{_1}} ... {i ident{_n} } \] } command.
+
+    {b ("ExtractionConstant", 0)} indicates {b Extract Constant {i qualid} => {i string}} command.
+
+    {b ("ExtractionInlinedConstant", 0)} indicates {b Extract Inlined Constant {i qualid} => {i string}} command.
+
+    {b ("ExtractionInductive", 0)} indicates {b Extract Inductive {i qualid} => {i string} [ {i string} ... {string} ] {i optstring}} command.
+
+    {b ("ExtractionBlacklist", 0)} indicates {b Extraction Blacklist {i ident{_1}} ... {i ident{_n}}} command.
+ *)
+type extend_name =
+  (** Name of the vernac entry where the tactic is defined, typically found
+      after the VERNAC EXTEND statement in the source. *)
+  string *
+  (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch
+      is given an offset, starting from zero. *)
+  int
+
+(* This type allows registering the inlining of constants in native compiler.
+   It will be extended with primitive inductive types and operators *)
+type register_kind =
+  | RegisterInline
+
+type bullet = Proof_bullet.t
+[@@ocaml.deprecated "Alias type, please use [Proof_bullet.t]"]
+
+(** {6 Types concerning the module layer} *)
+
+(** Rigid / flexible module signature *)
+
+type 'a module_signature = 'a Declaremods.module_signature =
+  | Enforce of 'a (** ... : T *)
+        [@ocaml.deprecated "Use the constructor in module [Declaremods]"]
+  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
+        [@ocaml.deprecated "Use the constructor in module [Declaremods]"]
+[@@ocaml.deprecated "please use [Declaremods.module_signature]."]
+
+(** Which module inline annotations should we honor,
+    either None or the ones whose level is less or equal
+    to the given integer *)
+
+type inline = Declaremods.inline =
+  | NoInline
+      [@ocaml.deprecated "Use the constructor in module [Declaremods]"]
+  | DefaultInline
+      [@ocaml.deprecated "Use the constructor in module [Declaremods]"]
+  | InlineAt of int
+      [@ocaml.deprecated "Use the constructor in module [Declaremods]"]
+[@@ocaml.deprecated "please use [Declaremods.inline]."]
+
+type module_ast_inl = module_ast * Declaremods.inline
+type module_binder = bool option * lident list * module_ast_inl
+
+(** [Some b] if locally enabled/disabled according to [b], [None] if
+    we should use the global flag. *)
+type vernac_cumulative = VernacCumulative | VernacNonCumulative
+
+(** {6 The type of vernacular expressions} *)
+
+type vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit
+
+type vernac_argument_status = {
+  name : Name.t;
+  recarg_like : bool;
+  notation_scope : string CAst.t option;
+  implicit_status : vernac_implicit_status;
+}
+
+type nonrec vernac_expr =
+
+  | VernacLoad of verbose_flag * string
+  (* Syntax *)
+  | VernacSyntaxExtension of bool * (lstring * syntax_modifier list)
+  | VernacOpenCloseScope of bool * scope_name
+  | VernacDelimiters of scope_name * string option
+  | VernacBindScope of scope_name * class_rawexpr list
+  | VernacInfix of (lstring * syntax_modifier list) *
+      constr_expr * scope_name option
+  | VernacNotation of
+      constr_expr * (lstring * syntax_modifier list) *
+      scope_name option
+  | VernacNotationAddFormat of string * string * string
+  | VernacDeclareCustomEntry of string
+
+  (* Gallina *)
+  | VernacDefinition of (Decl_kinds.discharge * Decl_kinds.definition_object_kind) * name_decl * definition_expr
+  | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list
+  | VernacEndProof of proof_end
+  | VernacExactProof of constr_expr
+  | VernacAssumption of (Decl_kinds.discharge * Decl_kinds.assumption_object_kind) *
+      Declaremods.inline * (ident_decl list * constr_expr) with_coercion list
+  | VernacInductive of vernac_cumulative option * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list
+  | VernacFixpoint of Decl_kinds.discharge * (fixpoint_expr * decl_notation list) list
+  | VernacCoFixpoint of Decl_kinds.discharge * (cofixpoint_expr * decl_notation list) list
+  | VernacScheme of (lident option * scheme) list
+  | VernacCombinedScheme of lident * lident list
+  | VernacUniverse of lident list
+  | VernacConstraint of Glob_term.glob_constraint list
+
+  (* Gallina extensions *)
+  | VernacBeginSection of lident
+  | VernacEndSegment of lident
+  | VernacRequire of
+      qualid option * export_flag option * qualid list
+  | VernacImport of export_flag * qualid list
+  | VernacCanonical of qualid or_by_notation
+  | VernacCoercion of qualid or_by_notation *
+      class_rawexpr * class_rawexpr
+  | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr
+  | VernacNameSectionHypSet of lident * section_subset_expr
+
+  (* Type classes *)
+  | VernacInstance of
+      bool * (* abstract instance *)
+      local_binder_expr list * (* super *)
+        typeclass_constraint * (* instance name, class name, params *)
+        (bool * constr_expr) option * (* props *)
+        Hints.hint_info_expr
+
+  | VernacContext of local_binder_expr list
+
+  | VernacDeclareInstances of
+    (qualid * Hints.hint_info_expr) list (* instances names, priorities and patterns *)
+
+  | VernacDeclareClass of qualid (* inductive or definition name *)
+
+  (* Modules and Module Types *)
+  | VernacDeclareModule of bool option * lident *
+      module_binder list * module_ast_inl
+  | VernacDefineModule of bool option * lident * module_binder list *
+      module_ast_inl Declaremods.module_signature * module_ast_inl list
+  | VernacDeclareModuleType of lident *
+      module_binder list * module_ast_inl list * module_ast_inl list
+  | VernacInclude of module_ast_inl list
+
+  (* Solving *)
+
+  | VernacSolveExistential of int * constr_expr
+
+  (* Auxiliary file and library management *)
+  | VernacAddLoadPath of rec_flag * string * DirPath.t option
+  | VernacRemoveLoadPath of string
+  | VernacAddMLPath of rec_flag * string
+  | VernacDeclareMLModule of string list
+  | VernacChdir of string option
+
+  (* State management *)
+  | VernacWriteState of string
+  | VernacRestoreState of string
+
+  (* Resetting *)
+  | VernacResetName of lident
+  | VernacResetInitial
+  | VernacBack of int
+  | VernacBackTo of int
+
+  (* Commands *)
+  | VernacCreateHintDb of string * bool
+  | VernacRemoveHints of string list * qualid list
+  | VernacHints of string list * Hints.hints_expr
+  | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) *
+      onlyparsing_flag
+  | VernacArguments of qualid or_by_notation *
+      vernac_argument_status list (* Main arguments status list *) *
+        (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) *
+      int option (* Number of args to trigger reduction *) *
+        [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename |
+          `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes |
+          `DefaultImplicits ] list
+  | VernacReserve of simple_binder list
+  | VernacGeneralizable of (lident list) option
+  | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list)
+  | VernacSetStrategy of
+      (Conv_oracle.level * qualid or_by_notation list) list
+  | VernacUnsetOption of export_flag * Goptions.option_name
+  | VernacSetOption of export_flag * Goptions.option_name * option_value
+  | VernacAddOption of Goptions.option_name * option_ref_value list
+  | VernacRemoveOption of Goptions.option_name * option_ref_value list
+  | VernacMemOption of Goptions.option_name * option_ref_value list
+  | VernacPrintOption of Goptions.option_name
+  | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr
+  | VernacGlobalCheck of constr_expr
+  | VernacDeclareReduction of string * Genredexpr.raw_red_expr
+  | VernacPrint of printable
+  | VernacSearch of searchable * Goal_select.t option * search_restriction
+  | VernacLocate of locatable
+  | VernacRegister of lident * register_kind
+  | VernacComments of comment list
+
+  (* Proof management *)
+  | VernacAbort of lident option
+  | VernacAbortAll
+  | VernacRestart
+  | VernacUndo of int
+  | VernacUndoTo of int
+  | VernacFocus of int option
+  | VernacUnfocus
+  | VernacUnfocused
+  | VernacBullet of Proof_bullet.t
+  | VernacSubproof of Goal_select.t option
+  | VernacEndSubproof
+  | VernacShow of showable
+  | VernacCheckGuard
+  | VernacProof of Genarg.raw_generic_argument option * section_subset_expr option
+  | VernacProofMode of string
+
+  (* For extension *)
+  | VernacExtend of extend_name * Genarg.raw_generic_argument list
+
+type vernac_flags = (string * vernac_flag_value) list
+and vernac_flag_value =
+  | VernacFlagEmpty
+  | VernacFlagLeaf of string
+  | VernacFlagList of vernac_flags
+
+type vernac_control =
+  | VernacExpr of vernac_flags * vernac_expr
+  (* boolean is true when the `-time` batch-mode command line flag was set.
+     the flag is used to print differently in `-time` vs `Time foo` *)
+  | VernacTime of bool * vernac_control CAst.t
+  | VernacRedirect of string * vernac_control CAst.t
+  | VernacTimeout of int * vernac_control
+  | VernacFail of vernac_control
+
+(* A vernac classifier provides information about the exectuion of a
+   command:
+
+   - vernac_when: encodes if the vernac may alter the parser [thus
+     forcing immediate execution], or if indeed it is pure and parsing
+     can continue without its execution.
+
+   - vernac_type: if it is starts, ends, continues a proof or
+     alters the global state or is a control command like BackTo or is
+     a query like Check.
+
+   The classification works on the assumption that we have 3 states:
+   parsing, execution (global enviroment, etc...), and proof
+   state. For example, commands that only alter the proof state are
+   considered safe to delegate to a worker.
+
+*)
+type vernac_type =
+  (* Start of a proof *)
+  | VtStartProof of vernac_start
+  (* Command altering the global state, bad for parallel
+     processing. *)
+  | VtSideff of vernac_sideff_type
+  (* End of a proof *)
+  | VtQed of vernac_qed_type
+  (* A proof step *)
+  | VtProofStep of proof_step
+  (* To be removed *)
+  | VtProofMode of string
+  (* Queries are commands assumed to be "pure", that is to say, they
+     don't modify the interpretation state. *)
+  | VtQuery
+  (* To be removed *)
+  | VtMeta
+  | VtUnknown
+and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *)
+and vernac_start = string * opacity_guarantee * Id.t list
+and vernac_sideff_type = Id.t list
+and opacity_guarantee =
+  | GuaranteesOpacity (** Only generates opaque terms at [Qed] *)
+  | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*)
+and proof_step = { (* TODO: inline with OCaml 4.03 *)
+  parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ];
+  proof_block_detection : proof_block_name option
+}
+and solving_tac = bool (* a terminator *)
+and anon_abstracting_tac = bool (* abstracting anonymously its result *)
+and proof_block_name = string (* open type of delimiters *)
+type vernac_when =
+  | VtNow
+  | VtLater
+type vernac_classification = vernac_type * vernac_when
diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml
index 1f2d2e4b..1bb1414f 100644
--- a/vernac/vernacinterp.ml
+++ b/vernac/vernacinterp.ml
@@ -12,15 +12,22 @@ open Util
 open Pp
 open CErrors
 
-type deprecation = bool
+type deprecation = { since : string option ; note : string option }
+
+let mk_deprecation ?(since=None) ?(note=None) () =
+  { since ; note }
 
 type atts = {
   loc : Loc.t option;
   locality : bool option;
   polymorphic : bool;
   program : bool;
+  deprecated : deprecation option;
 }
 
+let mk_atts ?(loc=None) ?(locality=None) ?(polymorphic=false) ?(program=false) ?(deprecated=None) () : atts =
+  { loc ; locality ; polymorphic ; program ; deprecated }
+
 type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t
 
 type plugin_args = Genarg.raw_generic_argument list
@@ -28,7 +35,7 @@ type plugin_args = Genarg.raw_generic_argument list
 (* Table of vernac entries *)
 let vernac_tab =
   (Hashtbl.create 211 :
-    (Vernacexpr.extend_name, deprecation * plugin_args vernac_command) Hashtbl.t)
+    (Vernacexpr.extend_name, bool * plugin_args vernac_command) Hashtbl.t)
 
 let vinterp_add depr s f =
   try
@@ -79,7 +86,6 @@ let call opn converted_args ~atts ~st =
     phase := "Executing command";
     hunk ~atts ~st
   with
-    | Drop -> raise Drop
     | reraise ->
         let reraise = CErrors.push reraise in
         if !Flags.debug then
diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli
index 935cacf7..46468b30 100644
--- a/vernac/vernacinterp.mli
+++ b/vernac/vernacinterp.mli
@@ -10,21 +10,27 @@
 
 (** Interpretation of extended vernac phrases. *)
 
-type deprecation = bool
+type deprecation = { since : string option ; note : string option }
+
+val mk_deprecation : ?since: string option -> ?note: string option -> unit -> deprecation
 
 type atts = {
   loc : Loc.t option;
   locality : bool option;
   polymorphic : bool;
   program : bool;
+  deprecated : deprecation option;
 }
 
+val mk_atts : ?loc: Loc.t option -> ?locality: bool option ->
+  ?polymorphic: bool -> ?program: bool -> ?deprecated: deprecation option -> unit -> atts
+
 type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t
 
 type plugin_args = Genarg.raw_generic_argument list
 
 val vinterp_init : unit -> unit
-val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit
+val vinterp_add : bool -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit
 val overwriting_vinterp_add : Vernacexpr.extend_name -> plugin_args vernac_command -> unit
 
 val call : Vernacexpr.extend_name -> plugin_args -> atts:atts -> st:Vernacstate.t -> Vernacstate.t
diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml
index a837b77a..0fdd2faa 100644
--- a/vernac/vernacprop.ml
+++ b/vernac/vernacprop.ml
@@ -31,7 +31,6 @@ let rec has_Fail = function
 let is_navigation_vernac_expr = function
   | VernacResetInitial
   | VernacResetName _
-  | VernacBacktrack _
   | VernacBackTo _
   | VernacBack _ -> true
   | _ -> false