From 297b0cb44bbe8ec7304ca635c566815167266d4a Mon Sep 17 00:00:00 2001
From: Jason Gross
Date: Wed, 24 Jun 2015 11:28:44 +0200
Subject: Revert commit 18796b6aea453bdeef1ad12ce80eeb220bf01e67, close 3080

This reverts 18796b6aea453bdeef1ad12ce80eeb220bf01e67 (Slight change
in the semantics of arguments scopes: scopes can no longer be bound to
Funclass or Sortclass (this does not seem to be useful)).  It is
useful to have function_scope for, e.g., function composition.  This
allows users to, e.g., automatically interpret ∘ as morphism
composition when expecting a morphism of categories, as functor
composition when expecting a functor, and as function composition when
expecting a function.

Additionally, it is nicer to have fewer special cases in the OCaml
code, and give more things a uniform syntax.  (The scope type_scope
should not be special-cased; this change is coming up next.)

Also explicitly define [function_scope] in theories/Init/Notations.v.

This closes bug #3080, Build a [function_scope] like [type_scope], or allow
[Bind Scope ... with Sortclass] and [Bind Scope ... with Funclass]

We now mention Funclass and Sortclass in the documentation of [Bind Scope]
again.
---
 pretyping/classops.mli | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index e2bb2d1a00..1858004900 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -26,6 +26,9 @@ val cl_typ_eq : cl_typ -> cl_typ -> bool
 
 val subst_cl_typ : substitution -> cl_typ -> cl_typ
 
+(** Comparison of [cl_typ] *)
+val cl_typ_ord : cl_typ -> cl_typ -> int
+
 (** This is the type of infos for declared classes *)
 type cl_info_typ = {
   cl_param : int }
-- 
cgit v1.2.3


From 2bc88f9a536c3db3c2d4a38a8a0da0500b895c7b Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 14 Sep 2015 18:35:48 +0200
Subject: Univs: Add universe binding lists to definitions

... lemmas and inductives to control which universes are bound and where
in universe polymorphic definitions. Names stay outside the kernel.
---
 pretyping/evd.ml  | 76 ++++++++++++++++++++++++++++++++++++++++---------------
 pretyping/evd.mli |  9 +++++--
 2 files changed, 63 insertions(+), 22 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 168a10df93..fc4f5e040e 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -277,15 +277,15 @@ end
 type evar_universe_context = 
  { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
    uctx_local : Univ.universe_context_set; (** The local context of variables *)
-    uctx_univ_variables : Universes.universe_opt_subst;
-      (** The local universes that are unification variables *)
-    uctx_univ_algebraic : Univ.universe_set; 
-    (** The subset of unification variables that
+   uctx_univ_variables : Universes.universe_opt_subst;
+   (** The local universes that are unification variables *)
+   uctx_univ_algebraic : Univ.universe_set; 
+   (** The subset of unification variables that
 	can be instantiated with algebraic universes as they appear in types 
 	and universe instances only. *)
-    uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
-    uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
-  }
+   uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
+   uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
+ }
   
 let empty_evar_universe_context = 
   { uctx_names = UNameMap.empty, Univ.LMap.empty;
@@ -769,10 +769,10 @@ let empty = {
   extras = Store.empty;
 }
 
-let from_env ?ctx e = 
-  match ctx with
-  | None -> { empty with universes = evar_universe_context_from e }
-  | Some ctx -> { empty with universes = ctx }
+let from_env e = 
+  { empty with universes = evar_universe_context_from e }
+
+let from_ctx ctx = { empty with universes = ctx }
 
 let has_undefined evd = not (EvMap.is_empty evd.undf_evars)
 
@@ -982,9 +982,43 @@ let evar_universe_context d = d.universes
 
 let universe_context_set d = d.universes.uctx_local
 
-let universe_context evd =
-  Univ.ContextSet.to_context evd.universes.uctx_local
+let pr_uctx_level uctx = 
+  let map, map_rev = uctx.uctx_names in 
+    fun l ->
+      try str(Univ.LMap.find l map_rev)
+      with Not_found -> 
+	Universes.pr_with_global_universes l
 
+let universe_context ?names evd =
+  match names with
+  | None -> Univ.ContextSet.to_context evd.universes.uctx_local
+  | Some pl ->
+     let levels = Univ.ContextSet.levels evd.universes.uctx_local in
+     let newinst, left =
+       List.fold_right
+         (fun (loc,id) (newinst, acc) ->
+	  let l =
+	    try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
+	    with Not_found ->
+	      user_err_loc (loc, "universe_context",
+			    str"Universe " ++ pr_id id ++ str" is not bound anymore.")
+	  in (l :: newinst, Univ.LSet.remove l acc))
+	 pl ([], levels)
+     in
+       if not (Univ.LSet.is_empty left) then
+         let n = Univ.LSet.cardinal left in
+           errorlabstrm "universe_context"
+			(str(CString.plural n "Universe") ++ spc () ++
+			     Univ.LSet.pr (pr_uctx_level evd.universes) left ++
+			     spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
+       else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst),
+				Univ.ContextSet.constraints evd.universes.uctx_local)
+
+let restrict_universe_context evd vars =
+  let uctx = evd.universes in
+  let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in
+    { evd with universes = { uctx with uctx_local = uctx' } }
+						 
 let universe_subst evd =
   evd.universes.uctx_univ_variables
 
@@ -1072,6 +1106,15 @@ let make_flexible_variable evd b u =
     {evd with universes = {ctx with uctx_univ_variables = uvars'; 
       uctx_univ_algebraic = avars'}}
 
+let make_evar_universe_context e l = 
+  let uctx = evar_universe_context_from e in
+    match l with
+    | None -> uctx
+    | Some us ->
+       List.fold_left (fun uctx (loc,id) ->
+		       fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) uctx))
+		      uctx us
+    
 (****************************************)
 (* Operations on constants              *)
 (****************************************)
@@ -1703,13 +1746,6 @@ let evar_dependency_closure n sigma =
 let has_no_evar sigma =
   EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars
 
-let pr_uctx_level uctx = 
-  let map, map_rev = uctx.uctx_names in 
-    fun l ->
-      try str(Univ.LMap.find l map_rev)
-      with Not_found -> 
-	Universes.pr_with_global_universes l
-
 let pr_evd_level evd = pr_uctx_level evd.universes
 
 let pr_evar_universe_context ctx =
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index f2d8a83350..94d9d5f662 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -129,10 +129,13 @@ type evar_map
 val empty : evar_map
 (** The empty evar map. *)
 
-val from_env : ?ctx:evar_universe_context -> env -> evar_map
+val from_env : env -> evar_map
 (** The empty evar map with given universe context, taking its initial 
     universes from env. *)
 
+val from_ctx : evar_universe_context -> evar_map
+(** The empty evar map with given universe context *)
+
 val is_empty : evar_map -> bool
 (** Whether an evarmap is empty. *)
 
@@ -484,6 +487,8 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context
   evar_universe_context
 val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
 
+val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context
+val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map							   
 (** Raises Not_found if not a name for a universe in this map. *)
 val universe_of_name : evar_map -> string -> Univ.universe_level
 val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map
@@ -527,7 +532,7 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool
 
 val evar_universe_context : evar_map -> evar_universe_context
 val universe_context_set : evar_map -> Univ.universe_context_set
-val universe_context : evar_map -> Univ.universe_context
+val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context
 val universe_subst : evar_map -> Universes.universe_opt_subst
 val universes : evar_map -> Univ.universes
 
-- 
cgit v1.2.3


From 04e9be59051ca60bf61d5142ac14386920876926 Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Fri, 18 Sep 2015 08:00:14 +0200
Subject: Do not compress match constructs when the inner match contains no
 branch. (Fix bug #4348)

---
 pretyping/detyping.ml | 1 +
 1 file changed, 1 insertion(+)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 28fb8cbe36..8bd57290b0 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -276,6 +276,7 @@ and align_tree nal isgoal (e,c as rhs) = match nal with
     match kind_of_term c with
     | Case (ci,p,c,cl) when
         eq_constr c (mkRel (List.index Name.equal na (fst (snd e))))
+        && not (Int.equal (Array.length cl) 0)
 	&& (* don't contract if p dependent *)
 	computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) ->
 	let clauses = build_tree na isgoal e ci cl in
-- 
cgit v1.2.3


From 592151e323036f0044a0ac285b8b13c964825989 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sat, 26 Sep 2015 14:06:38 +0200
Subject: Fixing bug #4347: Not_found Exception with some Records.

A term was reduced in an improper environment.
---
 pretyping/evarutil.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index ee6bbe7fbe..8ebb037c24 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -757,7 +757,7 @@ let define_evar_as_product evd (evk,args) =
 let define_pure_evar_as_lambda env evd evk =
   let evi = Evd.find_undefined evd evk in
   let evenv = evar_env evi in
-  let typ = whd_betadeltaiota env evd (evar_concl evi) in
+  let typ = whd_betadeltaiota evenv evd (evar_concl evi) in
   let evd1,(na,dom,rng) = match kind_of_term typ with
   | Prod (na,dom,rng) -> (evd,(na,dom,rng))
   | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
-- 
cgit v1.2.3


From f52826877059858fb3fcd4314c629ed63d90a042 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sat, 26 Sep 2015 19:50:41 +0200
Subject: Hardening the API of evarmaps.

The evar counter has been moved from Evarutil to Evd, and all functions in
Evarutil now go through a dedicated primitive to create a fresh evar from
an evarmap.
---
 pretyping/evarconv.ml  |  2 +-
 pretyping/evarutil.ml  | 31 +++++++++++++------------------
 pretyping/evarutil.mli |  1 -
 3 files changed, 14 insertions(+), 20 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index bb07bf0563..d5bb564f66 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -830,7 +830,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
 	      (i,t2::ks, m-1, test)
 	  else
 	    let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
-            let (i',ev) = new_evar env i ~src:dloc (substl ks b) in
+            let (i',ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
 	    (i', ev :: ks, m - 1,test))
 	(evd,[],List.length bs,fun i -> Success i) bs
     in
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index ee6bbe7fbe..6684b06048 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -239,17 +239,6 @@ let make_pure_subst evi args =
         | _ -> anomaly (Pp.str "Instance does not match its signature"))
     (evar_filtered_context evi) (Array.rev_to_list args,[]))
 
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_counter_summary_name = "evar counter"
-
-(* Generator of existential names *)
-let new_untyped_evar =
-  let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
-  fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
-
 (*------------------------------------*
  * functional operations on evar sets *
  *------------------------------------*)
@@ -354,17 +343,15 @@ let push_rel_context_to_named_context env typ =
 let default_source = (Loc.ghost,Evar_kinds.InternalHole)
 
 let restrict_evar evd evk filter candidates =
-  let evk' = new_untyped_evar () in
-  let evd = Evd.restrict evk evk' filter ?candidates evd in
+  let evd, evk' = Evd.restrict evk filter ?candidates evd in
   Evd.declare_future_goal evk' evd, evk'
 
 let new_pure_evar_full evd evi =
-  let evk = new_untyped_evar () in
-  let evd = Evd.add evd evk evi in
+  let (evd, evk) = Evd.new_evar evd evi in
   let evd = Evd.declare_future_goal evk evd in
   (evd, evk)
 
-let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
+let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
   let default_naming =
     if principal then
         (* waiting for a more principled approach
@@ -374,8 +361,16 @@ let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?nam
         Misctypes.IntroAnonymous
   in
   let naming = Option.default default_naming naming in
-  let newevk = new_untyped_evar() in
-  let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
+  let evi = {
+    evar_hyps = sign;
+    evar_concl = typ;
+    evar_body = Evar_empty;
+    evar_filter = filter;
+    evar_source = src;
+    evar_candidates = candidates;
+    evar_extra = store; }
+  in
+  let (evd, newevk) = Evd.new_evar evd ~naming evi in
   let evd =
     if principal then Evd.declare_principal_goal newevk evd
     else Evd.declare_future_goal newevk evd
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index f1d94b0a4f..76d67c748d 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -252,4 +252,3 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
   Evar_kinds.t Loc.located
 
 val meta_counter_summary_name : string
-val evar_counter_summary_name : string
-- 
cgit v1.2.3


From b6d5a9f47634371aa18c6e3159c6bc24203d229f Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 27 Sep 2015 14:22:29 +0200
Subject: Fixing loss of extra data in Evd.

---
 pretyping/evd.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index fc4f5e040e..6326112912 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1385,7 +1385,7 @@ let set_metas evd metas = {
   evar_names = evd.evar_names;
   future_goals = evd.future_goals;
   principal_future_goal = evd.principal_future_goal;
-  extras = Store.empty;
+  extras = evd.extras;
 }
 
 let meta_list evd = metamap_to_list evd.metas
-- 
cgit v1.2.3


From 9cadb903b7c3a3be8014152b293cd5ade3a7c8b7 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 27 Sep 2015 16:36:10 +0200
Subject: Removing subst_defined_metas_evars from Evd.

---
 pretyping/unification.ml | 13 +++++++++++++
 1 file changed, 13 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 24e06007e9..123f9b8cd3 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -554,6 +554,19 @@ let isAllowedEvar flags c = match kind_of_term c with
   | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
   | _ -> false
 
+
+let subst_defined_metas_evars (bl,el) c =
+  let rec substrec c = match kind_of_term c with
+    | Meta i ->
+      let select (j,_,_) = Int.equal i j in
+      substrec (pi2 (List.find select bl))
+    | Evar (evk,args) ->
+      let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
+      (try substrec (pi3 (List.find select el))
+       with Not_found -> map_constr substrec c)
+    | _ -> map_constr substrec c
+  in try Some (substrec c) with Not_found -> None
+
 let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
   match subst_defined_metas_evars (metasubst,[]) tyM with
   | None -> sigma
-- 
cgit v1.2.3


From e759333a8b5c11247c4cc134fdde8c1bd85a6e17 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 11 Sep 2015 18:07:39 +0200
Subject: Universes: enforce Set <= i for all Type occurrences.

---
 pretyping/evd.ml  | 41 +++++++++++++++++++++++++++--------------
 pretyping/evd.mli |  6 +++---
 2 files changed, 30 insertions(+), 17 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 6326112912..fe5f12dd8a 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -453,7 +453,7 @@ let add_constraints_context ctx cstrs =
   in
     { ctx with uctx_local = (univs, Univ.Constraint.union local local');
       uctx_univ_variables = vars;
-      uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes }
+      uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
 
 (* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
 (* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
@@ -1058,36 +1058,49 @@ let with_context_set rigid d (a, ctx) =
 let add_uctx_names s l (names, names_rev) =
     (UNameMap.add s l names, Univ.LMap.add l s names_rev)
 
-let uctx_new_univ_variable rigid name
+let uctx_new_univ_variable rigid name predicative
   ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
   let u = Universes.new_univ_level (Global.current_dirpath ()) in
   let ctx' = Univ.ContextSet.add_universe u ctx in
-  let uctx' = 
+  let uctx', pred =
     match rigid with
-    | UnivRigid -> uctx
+    | UnivRigid -> uctx, true
     | UnivFlexible b -> 
       let uvars' = Univ.LMap.add u None uvars in
 	if b then {uctx with uctx_univ_variables = uvars';
-	  uctx_univ_algebraic = Univ.LSet.add u avars}
-	else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in
+	  uctx_univ_algebraic = Univ.LSet.add u avars}, false
+	else {uctx with uctx_univ_variables = uvars'}, false
+  in
+  (* let ctx' = *)
+  (*   if pred then *)
+  (*     Univ.ContextSet.add_constraints *)
+  (* 	(Univ.Constraint.singleton (Univ.Level.set, Univ.Le, u)) ctx' *)
+  (*   else ctx' *)
+  (* in *)
   let names = 
     match name with
     | Some n -> add_uctx_names n u uctx.uctx_names
     | None -> uctx.uctx_names
   in
+  let initial =
+    Univ.add_universe u pred uctx.uctx_initial_universes
+  in						     
+  let uctx' =
     {uctx' with uctx_names = names; uctx_local = ctx';
-      uctx_universes = Univ.add_universe u uctx.uctx_universes}, u
-
-let new_univ_level_variable ?name rigid evd =
-  let uctx', u = uctx_new_univ_variable rigid name evd.universes in
+		uctx_universes = Univ.add_universe u pred uctx.uctx_universes;
+		uctx_initial_universes = initial}
+  in uctx', u
+						     
+let new_univ_level_variable ?name ?(predicative=true) rigid evd =
+  let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
     ({evd with universes = uctx'}, u)
 
-let new_univ_variable ?name rigid evd =
-  let uctx', u = uctx_new_univ_variable rigid name evd.universes in
+let new_univ_variable ?name ?(predicative=true) rigid evd =
+  let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
     ({evd with universes = uctx'}, Univ.Universe.make u)
 
-let new_sort_variable ?name rigid d =
-  let (d', u) = new_univ_variable rigid ?name d in
+let new_sort_variable ?name ?(predicative=true) rigid d =
+  let (d', u) = new_univ_variable rigid ?name ~predicative d in
     (d', Type u)
 
 let make_flexible_variable evd b u =
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 94d9d5f662..c2ccc6d21a 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -505,9 +505,9 @@ val normalize_evar_universe_context_variables : evar_universe_context ->
 val normalize_evar_universe_context : evar_universe_context -> 
   evar_universe_context
 
-val new_univ_level_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level
-val new_univ_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe
-val new_sort_variable : ?name:string -> rigid -> evar_map -> evar_map * sorts
+val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level
+val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe
+val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts
 val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
 val is_sort_variable : evar_map -> sorts -> Univ.universe_level option 
 (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is 
-- 
cgit v1.2.3


From 79163d582abc2e22512f0924675b6b0f0928f0ef Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 15 Sep 2015 18:31:44 +0200
Subject: Univs: Fix part of bug #4161

Rechecking applications built by evarconv's imitation.
---
 pretyping/evarsolve.ml | 43 +++++++++++++++++++++++++++++++++++++------
 1 file changed, 37 insertions(+), 6 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index ac1692f451..a2189d5e4f 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -107,6 +107,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
 let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c =
   let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in
     refresh_universes (Some false) env sigma ty
+		      
 
 (************************)
 (* Unification results  *)
@@ -127,6 +128,32 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd =
   | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd
   | None -> add_conv_pb ~tail (Reduction.CONV,env,t1,t2) evd
 
+(* We retype applications to ensure the universe constraints are collected *)
+
+let recheck_applications conv_algo env evdref t =
+  let rec aux env t =
+    match kind_of_term t with
+    | App (f, args) ->
+       let () = aux env f in
+       let fty = Retyping.get_type_of env !evdref f in
+       let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in
+       let rec aux i ty =
+	 if i < Array.length argsty then
+	 match kind_of_term (whd_betadeltaiota env !evdref ty) with
+	 | Prod (na, dom, codom) ->
+	    (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with
+	     | Success evd -> evdref := evd;
+			     aux (succ i) (subst1 args.(i) codom)
+	     | UnifFailure (evd, reason) ->
+		Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom))
+	 | _ -> assert false
+       else ()
+     in aux 0 fty
+    | _ ->
+       iter_constr_with_full_binders (fun d env -> push_rel d env) aux env t
+  in aux env t
+
+	  
 (*------------------------------------*
  * Restricting existing evars         *
  *------------------------------------*)
@@ -1404,10 +1431,10 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
               evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates);
               evar'')
         | None ->
-          (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
-            map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
-              imitate envk t in
-
+           (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
+	   map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+					imitate envk t
+  in
   let rhs = whd_beta evd rhs (* heuristic *) in
   let fast rhs = 
     let filter_ctxt = evar_filtered_context evi in
@@ -1426,8 +1453,12 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
   in
   let body =
     if fast rhs then nf_evar evd rhs
-    else imitate (env,0) rhs
- in (!evdref,body)
+    else
+      let t' = imitate (env,0) rhs in
+	if !progress then
+	  (recheck_applications conv_algo (evar_env evi) evdref t'; t')
+	else t'
+  in (!evdref,body)
 
 (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
  * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
-- 
cgit v1.2.3


From 1cd87577ab85a402fb0482678dfcdbe85b45ce38 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 15 Sep 2015 18:33:04 +0200
Subject: Univs: force all universes to be >= Set.

---
 pretyping/evd.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index fe5f12dd8a..9f2d284387 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -385,7 +385,7 @@ let process_universe_constraints univs vars alg cstrs =
 		  let levels = Univ.Universe.levels l in
 		    Univ.LSet.fold (fun l local ->
 		      if Univ.Level.is_small l || Univ.LMap.mem l !vars then
-			Univ.enforce_eq (Univ.Universe.make l) r local
+			unify_universes fo (Univ.Universe.make l) Universes.UEq r local
 		      else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
 		      levels local
 		else
@@ -1083,11 +1083,11 @@ let uctx_new_univ_variable rigid name predicative
     | None -> uctx.uctx_names
   in
   let initial =
-    Univ.add_universe u pred uctx.uctx_initial_universes
+    Univ.add_universe u true uctx.uctx_initial_universes
   in						     
   let uctx' =
     {uctx' with uctx_names = names; uctx_local = ctx';
-		uctx_universes = Univ.add_universe u pred uctx.uctx_universes;
+		uctx_universes = Univ.add_universe u true uctx.uctx_universes;
 		uctx_initial_universes = initial}
   in uctx', u
 						     
-- 
cgit v1.2.3


From 4838a3a3c25cc9f7583dd62e4585460aca8ee961 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 21 Sep 2015 11:55:32 +0200
Subject: Forcing i > Set for global universes (incomplete)

---
 pretyping/evd.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 9f2d284387..a25479d483 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1083,11 +1083,11 @@ let uctx_new_univ_variable rigid name predicative
     | None -> uctx.uctx_names
   in
   let initial =
-    Univ.add_universe u true uctx.uctx_initial_universes
+    Univ.add_universe u false uctx.uctx_initial_universes
   in						     
   let uctx' =
     {uctx' with uctx_names = names; uctx_local = ctx';
-		uctx_universes = Univ.add_universe u true uctx.uctx_universes;
+		uctx_universes = Univ.add_universe u false uctx.uctx_universes;
 		uctx_initial_universes = initial}
   in uctx', u
 						     
-- 
cgit v1.2.3


From 91f5467917266a85496fb718dfc30eff3565d4dc Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 23 Sep 2015 16:20:42 +0200
Subject: Univs (evd): deal with global universes and sideff

- Fix union of universe contexts to keep declarations
- Fix side-effect handling to register new global universes
  in the graph.
---
 pretyping/evd.ml  | 137 ++++++++++++++++++++++++++++++++++++------------------
 pretyping/evd.mli |   2 +
 2 files changed, 95 insertions(+), 44 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index a25479d483..8243f96c16 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -310,6 +310,9 @@ let union_evar_universe_context ctx ctx' =
   else
     let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
     let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
+    let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
+			       (Univ.ContextSet.levels ctx.uctx_local) in
+    let declarenew g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g in	
     let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
       { uctx_names = (names, names_rev);
 	uctx_local = local;
@@ -317,12 +320,12 @@ let union_evar_universe_context ctx ctx' =
 	  Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
 	uctx_univ_algebraic = 
 	  Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
-	uctx_initial_universes = ctx.uctx_initial_universes;
+	uctx_initial_universes = declarenew ctx.uctx_initial_universes;
 	uctx_universes = 
 	  if local == ctx.uctx_local then ctx.uctx_universes
 	  else
 	    let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
-	      Univ.merge_constraints cstrsr ctx.uctx_universes }
+	      Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
 
 (* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *)
 (* let union_evar_universe_context =  *)
@@ -935,38 +938,6 @@ let evars_of_filtered_evar_info evi =
 	| Evar_defined b -> evars_of_term b)
 	(evars_of_named_context (evar_filtered_context evi)))
 
-(**********************************************************)
-(* Side effects *)
-
-let emit_side_effects eff evd =
-  { evd with effects = Declareops.union_side_effects eff evd.effects; }
-
-let drop_side_effects evd =
-  { evd with effects = Declareops.no_seff; }
-
-let eval_side_effects evd = evd.effects
-
-(* Future goals *)
-let declare_future_goal evk evd =
-  { evd with future_goals = evk::evd.future_goals }
-
-let declare_principal_goal evk evd =
-  match evd.principal_future_goal with
-  | None -> { evd with
-    future_goals = evk::evd.future_goals;
-    principal_future_goal=Some evk; }
-  | Some _ -> Errors.error "Only one main subgoal per instantiation."
-
-let future_goals evd = evd.future_goals
-
-let principal_future_goal evd = evd.principal_future_goal
-
-let reset_future_goals evd =
-  { evd with future_goals = [] ; principal_future_goal=None }
-
-let restore_future_goals evd gls pgl =
-  { evd with future_goals = gls ; principal_future_goal = pgl }
-
 (**********************************************************)
 (* Sort variables *)
 
@@ -1022,13 +993,13 @@ let restrict_universe_context evd vars =
 let universe_subst evd =
   evd.universes.uctx_univ_variables
 
-let merge_uctx rigid uctx ctx' =
+let merge_uctx sideff rigid uctx ctx' =
   let open Univ in
-  let uctx = 
+  let levels = ContextSet.levels ctx' in
+  let uctx = if sideff then uctx else
     match rigid with
     | UnivRigid -> uctx
     | UnivFlexible b ->
-      let levels = ContextSet.levels ctx' in
       let fold u accu =
         if LMap.mem u accu then accu
         else LMap.add u None accu
@@ -1039,12 +1010,23 @@ let merge_uctx rigid uctx ctx' =
 	  uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
 	else { uctx with uctx_univ_variables = uvars' }
   in
-  let uctx_local = ContextSet.append ctx' uctx.uctx_local in
-  let uctx_universes = merge_constraints (ContextSet.constraints ctx') uctx.uctx_universes in
-  { uctx with uctx_local; uctx_universes }
+  let uctx_local =
+    if sideff then uctx.uctx_local
+    else ContextSet.append ctx' uctx.uctx_local
+  in
+  let declare g =
+    LSet.fold (fun u g ->
+	       try Univ.add_universe u false g
+	       with Univ.AlreadyDeclared when sideff -> g)
+	      levels g
+  in
+  let initial = declare uctx.uctx_initial_universes in
+  let univs = declare uctx.uctx_universes in
+  let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
+    { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
 
 let merge_context_set rigid evd ctx' = 
-  {evd with universes = merge_uctx rigid evd.universes ctx'}
+  {evd with universes = merge_uctx false rigid evd.universes ctx'}
 
 let merge_uctx_subst uctx s =
   { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
@@ -1055,6 +1037,24 @@ let merge_universe_subst evd subst =
 let with_context_set rigid d (a, ctx) = 
   (merge_context_set rigid d ctx, a)
 
+let emit_universe_side_effects eff u =
+  Declareops.fold_side_effects
+    (fun acc eff ->
+     match eff with
+     | Declarations.SEscheme (l,s) ->
+	List.fold_left
+	  (fun acc (_,_,cb,c) ->
+	   let acc = match c with
+	     | `Nothing -> acc
+	     | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx
+	   in if cb.Declarations.const_polymorphic then acc
+	      else
+		merge_uctx true univ_rigid acc
+			   (Univ.ContextSet.of_context cb.Declarations.const_universes))
+	  acc l
+     | Declarations.SEsubproof _ -> acc)
+    u eff
+        
 let add_uctx_names s l (names, names_rev) =
     (UNameMap.add s l names, Univ.LMap.add l s names_rev)
 
@@ -1103,6 +1103,18 @@ let new_sort_variable ?name ?(predicative=true) rigid d =
   let (d', u) = new_univ_variable rigid ?name ~predicative d in
     (d', Type u)
 
+let add_global_univ d u =
+  let uctx = d.universes in
+  let initial =
+    Univ.add_universe u true uctx.uctx_initial_universes
+  in
+  let univs = 
+    Univ.add_universe u true uctx.uctx_universes
+  in
+    { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
+				     uctx_initial_universes = initial;
+				     uctx_universes = univs } }
+      
 let make_flexible_variable evd b u =
   let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in
   let uvars' = Univ.LMap.add u None uvars in
@@ -1291,12 +1303,16 @@ let refresh_undefined_univ_variables uctx =
 	Univ.LMap.add (Univ.subst_univs_level_level subst u) 
           (Option.map (Univ.subst_univs_level_universe subst) v) acc)
       uctx.uctx_univ_variables Univ.LMap.empty
-  in 
+  in
+  let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g)
+				   (Univ.ContextSet.levels ctx') g in
+  let initial = declare uctx.uctx_initial_universes in
+  let univs = declare Univ.initial_universes in
   let uctx' = {uctx_names = uctx.uctx_names;
 	       uctx_local = ctx'; 
 	       uctx_univ_variables = vars; uctx_univ_algebraic = alg;
-	       uctx_universes = Univ.initial_universes;
-	       uctx_initial_universes = uctx.uctx_initial_universes } in
+	       uctx_universes = univs;
+	       uctx_initial_universes = initial } in
     uctx', subst
 
 let refresh_undefined_universes evd =
@@ -1382,6 +1398,39 @@ let e_eq_constr_univs evdref t u =
   let evd, b = eq_constr_univs !evdref t u in
     evdref := evd; b
 
+(**********************************************************)
+(* Side effects *)
+
+let emit_side_effects eff evd =
+  { evd with effects = Declareops.union_side_effects eff evd.effects;
+	     universes = emit_universe_side_effects eff evd.universes }
+
+let drop_side_effects evd =
+  { evd with effects = Declareops.no_seff; }
+
+let eval_side_effects evd = evd.effects
+
+(* Future goals *)
+let declare_future_goal evk evd =
+  { evd with future_goals = evk::evd.future_goals }
+
+let declare_principal_goal evk evd =
+  match evd.principal_future_goal with
+  | None -> { evd with
+    future_goals = evk::evd.future_goals;
+    principal_future_goal=Some evk; }
+  | Some _ -> Errors.error "Only one main subgoal per instantiation."
+
+let future_goals evd = evd.future_goals
+
+let principal_future_goal evd = evd.principal_future_goal
+
+let reset_future_goals evd =
+  { evd with future_goals = [] ; principal_future_goal=None }
+
+let restore_future_goals evd gls pgl =
+  { evd with future_goals = gls ; principal_future_goal = pgl }
+
 (**********************************************************)
 (* Accessing metas *)
 
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index c2ccc6d21a..5a59c1776c 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -508,6 +508,8 @@ val normalize_evar_universe_context : evar_universe_context ->
 val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level
 val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe
 val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts
+val add_global_univ : evar_map -> Univ.Level.t -> evar_map
+											   
 val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
 val is_sort_variable : evar_map -> sorts -> Univ.universe_level option 
 (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is 
-- 
cgit v1.2.3


From 02aace9f038d579e9cf32dc2f5b21d415e977c03 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 23 Sep 2015 16:23:43 +0200
Subject: Univs (pretyping): allow parsing and decl of Top.n

This allows pretyping and detyping to be inverses regarding universes,
and makes Function's detyping/pretyping manipulations bearable in
presence of global universes that must be declared (otherwise an evd
would need to be threaded there in many places as well).
---
 pretyping/pretyping.ml | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 2858a5c1fe..edb76e52f4 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -102,14 +102,27 @@ let ((constr_in : constr -> Dyn.t),
 (** Miscellaneous interpretation functions *)
 let interp_universe_level_name evd s =
   let names, _ = Universes.global_universe_names () in
-  try
-    let id = try Id.of_string s with _ -> raise Not_found in
-      evd, Idmap.find id names
-  with Not_found ->
-    try let level = Evd.universe_of_name evd s in
-	  evd, level
-    with Not_found -> 
-      new_univ_level_variable ~name:s univ_rigid evd
+    if CString.string_contains s "." then
+      match List.rev (CString.split '.' s) with
+      | [] -> anomaly (str"Invalid universe name " ++ str s)
+      | n :: dp -> 
+	 let num = int_of_string n in
+	 let dp = DirPath.make (List.map Id.of_string dp) in
+	 let level = Univ.Level.make dp num in
+	 let evd =
+	   try Evd.add_global_univ evd level
+	   with Univ.AlreadyDeclared -> evd
+	 in evd, level
+    else 
+      try
+	let id =
+	  try Id.of_string s with _ -> raise Not_found in
+	  evd, Idmap.find id names
+      with Not_found ->
+	try let level = Evd.universe_of_name evd s in
+	      evd, level
+	with Not_found -> 
+	  new_univ_level_variable ~name:s univ_rigid evd
 
 let interp_universe evd = function
   | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
-- 
cgit v1.2.3


From 91b1808056602f3e26d1eb1bdf7be1e791cb742d Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 23 Sep 2015 16:35:07 +0200
Subject: Univs: fix many evar_map initializations and leaks.

---
 pretyping/typeclasses.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 18e83056bd..2ef2896506 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -370,7 +370,7 @@ let add_instance check inst =
   List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path
     (is_local inst) pri poly)
     (build_subclasses ~check:(check && not (isVarRef inst.is_impl))
-       (Global.env ()) Evd.empty inst.is_impl inst.is_pri)
+       (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri)
 
 let rebuild_instance (action, inst) =
   let () = match action with
-- 
cgit v1.2.3


From c92946243ccb0b11cd138f040a5297979229c3f5 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 23 Sep 2015 19:01:31 +0200
Subject: Univs: fix after rebase (from_ctx/from_env)

---
 pretyping/evd.ml | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 8243f96c16..842b87c57e 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1136,9 +1136,10 @@ let make_evar_universe_context e l =
     match l with
     | None -> uctx
     | Some us ->
-       List.fold_left (fun uctx (loc,id) ->
-		       fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) uctx))
-		      uctx us
+       List.fold_left
+	 (fun uctx (loc,id) ->
+	  fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx))
+	 uctx us
     
 (****************************************)
 (* Operations on constants              *)
-- 
cgit v1.2.3


From b3d97c2147418f44fc704807d3812b04921591af Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 1 Oct 2015 15:36:57 +0200
Subject: Univs: fix bug #4251, handling of template polymorphic constants.

---
 pretyping/pretyping.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index edb76e52f4..f18657da82 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -645,7 +645,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       match evar_kind_of_term !evdref resj.uj_val with
       | App (f,args) ->
         let f = whd_evar !evdref f in
-          if isInd f && is_template_polymorphic env f then
+          if is_template_polymorphic env f then
 	    (* Special case for inductive type applications that must be 
 	       refreshed right away. *)
 	    let sigma = !evdref in
-- 
cgit v1.2.3


From 07f4e6b07775052cc1c5dc34cdfa7ad4eacfa94f Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Sun, 4 Oct 2015 14:50:45 +0200
Subject: Fix bug #4354: interpret hints in the right env and sigma.

---
 pretyping/evd.ml | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 842b87c57e..4e0b6f75e7 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -312,7 +312,10 @@ let union_evar_universe_context ctx ctx' =
     let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
     let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
 			       (Univ.ContextSet.levels ctx.uctx_local) in
-    let declarenew g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g in	
+    let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
+    let declarenew g =
+      Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g
+    in
     let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
       { uctx_names = (names, names_rev);
 	uctx_local = local;
-- 
cgit v1.2.3


From df9caebb04fb681ec66b79c41ae01918cd2336de Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 6 Oct 2015 09:58:20 +0200
Subject: Univs (pretyping): call vm_compute/native_compute with the current
 universe graph

---
 pretyping/pretyping.ml | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index f18657da82..2efd8fe413 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -903,7 +903,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
 	      if not (occur_existential cty || occur_existential tval) then
 		begin 
-		  try 
+		  try
+		    let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in 
 		    ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
 		  with Reduction.NotConvertible -> 
 		    error_actual_type_loc loc env !evdref cj tval 
@@ -915,6 +916,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
  	    let cj = pretype empty_tycon env evdref lvar c in
 	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
             let evars = Nativenorm.evars_of_evar_map !evdref in
+	    let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in 
             begin
               try
                 ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj
-- 
cgit v1.2.3


From 84add29c036735ceacde73ea98a9a5a454a5e3a0 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Tue, 6 Oct 2015 19:09:10 +0200
Subject: Splitting kernel universe code in two modules.

1. The Univ module now only cares about definitions about universes.
2. The UGraph module contains the algorithm responsible for aciclicity.
---
 pretyping/pretyping.ml     | 2 +-
 pretyping/reductionops.mli | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 2efd8fe413..6373e60791 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -111,7 +111,7 @@ let interp_universe_level_name evd s =
 	 let level = Univ.Level.make dp num in
 	 let evd =
 	   try Evd.add_global_univ evd level
-	   with Univ.AlreadyDeclared -> evd
+	   with UGraph.AlreadyDeclared -> evd
 	 in evd, level
     else 
       try
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 1df2a73b2e..5e1c467c82 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -251,7 +251,7 @@ type conversion_test = constraints -> constraints
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
-val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit
+val sort_cmp : env -> conv_pb -> sorts -> sorts -> UGraph.t -> unit
 
 val is_conv : env ->  evar_map -> constr -> constr -> bool
 val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
-- 
cgit v1.2.3


From d37aab528dca587127b9f9944e1521e4fc3d9cc7 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 7 Oct 2015 13:11:52 +0200
Subject: Univs: add Strict Universe Declaration option (on by default)

This option disallows "declare at first use" semantics for universe
variables (in @{}), forcing the declaration of _all_ universes appearing
in a definition when introducing it with syntax Definition/Inductive
foo@{i j k} .. The bound universes at the end of a definition/inductive
must be exactly those ones, no extras allowed currently.
Test-suite files using the old semantics just disable the option.
---
 pretyping/detyping.ml  |  4 ++--
 pretyping/evd.ml       |  6 ------
 pretyping/miscops.ml   |  2 +-
 pretyping/pretyping.ml | 26 ++++++++++++++++++++++----
 4 files changed, 25 insertions(+), 13 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 8bd57290b0..a1213e72be 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -401,7 +401,7 @@ let detype_sort sigma = function
   | Type u ->
     GType
       (if !print_universes
-       then [Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)]
+       then [dl, Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)]
        else [])
 
 type binder_kind = BProd | BLambda | BLetIn
@@ -413,7 +413,7 @@ let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index
 let set_detype_anonymous f = detype_anonymous := f
 
 let detype_level sigma l =
-  GType (Some (Pp.string_of_ppcmds (Evd.pr_evd_level sigma l)))
+  GType (Some (dl, Pp.string_of_ppcmds (Evd.pr_evd_level sigma l)))
 
 let detype_instance sigma l = 
   if Univ.Instance.is_empty l then None
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 4e0b6f75e7..4372668fcf 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1074,12 +1074,6 @@ let uctx_new_univ_variable rigid name predicative
 	  uctx_univ_algebraic = Univ.LSet.add u avars}, false
 	else {uctx with uctx_univ_variables = uvars'}, false
   in
-  (* let ctx' = *)
-  (*   if pred then *)
-  (*     Univ.ContextSet.add_constraints *)
-  (* 	(Univ.Constraint.singleton (Univ.Level.set, Univ.Le, u)) ctx' *)
-  (*   else ctx' *)
-  (* in *)
   let names = 
     match name with
     | Some n -> add_uctx_names n u uctx.uctx_names
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index 0926e7a299..a0ec1baae2 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -30,7 +30,7 @@ let smartmap_cast_type f c =
 let glob_sort_eq g1 g2 = match g1, g2 with
 | GProp, GProp -> true
 | GSet, GSet -> true
-| GType l1, GType l2 -> List.equal CString.equal l1 l2
+| GType l1, GType l2 -> List.equal (fun x y -> CString.equal (snd x) (snd y)) l1 l2
 | _ -> false
 
 let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 2efd8fe413..dec23328f4 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -99,8 +99,22 @@ let search_guard loc env possible_indexes fixdefs =
 let ((constr_in : constr -> Dyn.t),
      (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
 
+(* To force universe name declaration before use *)
+
+let strict_universe_declarations = ref true
+let is_strict_universe_declarations () = !strict_universe_declarations
+
+let _ =
+  Goptions.(declare_bool_option
+	  { optsync  = true;
+            optdepr  = false;
+	    optname  = "strict universe declaration";
+	    optkey   = ["Strict";"Universe";"Declaration"];
+	    optread  = is_strict_universe_declarations;
+	    optwrite = (:=) strict_universe_declarations })
+						  
 (** Miscellaneous interpretation functions *)
-let interp_universe_level_name evd s =
+let interp_universe_level_name evd (loc,s) =
   let names, _ = Universes.global_universe_names () in
     if CString.string_contains s "." then
       match List.rev (CString.split '.' s) with
@@ -122,7 +136,10 @@ let interp_universe_level_name evd s =
 	try let level = Evd.universe_of_name evd s in
 	      evd, level
 	with Not_found -> 
-	  new_univ_level_variable ~name:s univ_rigid evd
+	  if not (is_strict_universe_declarations ()) then
+  	    new_univ_level_variable ~name:s univ_rigid evd
+	  else user_err_loc (loc, "interp_universe_level_name",
+			     Pp.(str "Undeclared universe: " ++ str s))
 
 let interp_universe evd = function
   | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
@@ -135,7 +152,7 @@ let interp_universe evd = function
 
 let interp_universe_level evd = function
   | None -> new_univ_level_variable univ_rigid evd
-  | Some s -> interp_universe_level_name evd s
+  | Some (loc,s) -> interp_universe_level_name evd (loc,s)
 
 let interp_sort evd = function
   | GProp -> evd, Prop Null
@@ -357,7 +374,8 @@ let evar_kind_of_term sigma c =
 (*************************************************************************)
 (* Main pretyping function                                               *)
 
-let interp_universe_level_name evd = function
+let interp_universe_level_name evd l =
+  match l with
   | GProp -> evd, Univ.Level.prop
   | GSet -> evd, Univ.Level.set
   | GType s -> interp_universe_level evd s
-- 
cgit v1.2.3


From 08a0c44e3525d1f0c7303d189e826e25c3e3d914 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 7 Oct 2015 16:00:16 +0200
Subject: Univs: fix FingerTree contrib.

Let merge_context_set be lenient when merging the context of side
effects of an entry from solve_by_tac.
---
 pretyping/evd.ml  | 4 ++--
 pretyping/evd.mli | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 4372668fcf..412fb92b3d 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1028,8 +1028,8 @@ let merge_uctx sideff rigid uctx ctx' =
   let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
     { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
 
-let merge_context_set rigid evd ctx' = 
-  {evd with universes = merge_uctx false rigid evd.universes ctx'}
+let merge_context_set ?(sideff=false) rigid evd ctx' = 
+  {evd with universes = merge_uctx sideff rigid evd.universes ctx'}
 
 let merge_uctx_subst uctx s =
   { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 5a59c1776c..52d7d42120 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -542,7 +542,7 @@ val universes : evar_map -> Univ.universes
 val merge_universe_context : evar_map -> evar_universe_context -> evar_map
 val set_universe_context : evar_map -> evar_universe_context -> evar_map
 
-val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map
+val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map
 val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map
 
 val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a
-- 
cgit v1.2.3


From d6ff0fcefa21bd2c6424627049b0f5e49ed4df12 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 8 Oct 2015 14:58:11 +0200
Subject: Univs: fix bug #4161.

Retypecheck abstracted infered predicate to register the right
universe constraints.
---
 pretyping/cases.ml | 32 ++++++++++++++++----------------
 1 file changed, 16 insertions(+), 16 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 05e09b9686..2a4be9f31c 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1865,7 +1865,14 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
 
 (* We put the tycon inside the arity signature, possibly discovering dependencies. *)
 
-let prepare_predicate_from_arsign_tycon loc tomatchs arsign c =
+let context_of_arsign l =
+  let (x, _) = List.fold_right
+    (fun c (x, n) ->
+       (lift_rel_context n c @ x, List.length c + n))
+    l ([], 0)
+  in x
+
+let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
   let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
   let subst, len =
     List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
@@ -1905,7 +1912,9 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c =
 	      mkRel (n + nar))
       | _ ->
 	  map_constr_with_binders succ predicate lift c
-  in predicate 0 c
+  in
+  let p = predicate 0 c in
+  fst (Typing.type_of (push_rel_context (context_of_arsign arsign) env) sigma p), p
 
 
 (* Builds the predicate. If the predicate is dependent, its context is
@@ -1927,11 +1936,11 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
 	(* If the tycon is not closed w.r.t real variables, we try *)
         (* two different strategies *)
 	(* First strategy: we abstract the tycon wrt to the dependencies *)
-        let pred1 =
-          prepare_predicate_from_arsign_tycon loc tomatchs arsign t in
+        let sigma1,pred1 =
+          prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in
 	(* Second strategy: we build an "inversion" predicate *)
 	let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
-	[sigma, pred1; sigma2, pred2]
+	[sigma1, pred1; sigma2, pred2]
     | None, _ ->
 	(* No dependent type constraint, or no constraints at all: *)
 	(* we use two strategies *)
@@ -2366,13 +2375,6 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
     assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *)
     arsign'', allnames, nar, eqs, neqs, refls
 
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) ->
-       (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
-
 let compile_program_cases loc style (typing_function, evdref) tycon env
     (predopt, tomatchl, eqns) =
   let typing_fun tycon env = function
@@ -2404,10 +2406,8 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
     | Some t ->
 	let pred = 
 	  try
-	    let pred = prepare_predicate_from_arsign_tycon loc tomatchs sign t in
-	      (* The tycon may be ill-typed after abstraction. *)
-	    let env' = push_rel_context (context_of_arsign sign) env in
-	      ignore(Typing.sort_of env' evdref pred); pred
+	    let evd, pred = prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t in
+	      evdref := evd; pred
 	  with e when Errors.noncritical e ->
 	    let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in
 	      lift nar t
-- 
cgit v1.2.3


From b6edcae7b61ea6ccc0e65223cecb71cab0dd55cc Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 8 Oct 2015 16:00:06 +0200
Subject: Univs: fix bug #3807

Add a flag to disallow minimization to set
---
 pretyping/evd.ml       | 3 +--
 pretyping/pretyping.ml | 9 +++++++++
 2 files changed, 10 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 412fb92b3d..3d912ca4ce 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1324,8 +1324,7 @@ let normalize_evar_universe_context uctx =
       Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
         uctx.uctx_univ_algebraic
     in
-      if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then 
-        uctx
+      if Univ.ContextSet.equal us' uctx.uctx_local then uctx
       else
 	let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
 	let uctx' = 
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index dec23328f4..6306739b7a 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -112,6 +112,15 @@ let _ =
 	    optkey   = ["Strict";"Universe";"Declaration"];
 	    optread  = is_strict_universe_declarations;
 	    optwrite = (:=) strict_universe_declarations })
+
+let _ =
+  Goptions.(declare_bool_option
+	  { optsync  = true;
+            optdepr  = false;
+	    optname  = "minimization to Set";
+	    optkey   = ["Universe";"set";"Minimization"];
+	    optread  = Universes.is_set_minimization;
+	    optwrite = (:=) Universes.set_minimization })
 						  
 (** Miscellaneous interpretation functions *)
 let interp_universe_level_name evd (loc,s) =
-- 
cgit v1.2.3


From 864bcb82f84a8101fec9a8f7225a01083ebff8c4 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 9 Oct 2015 11:01:54 +0200
Subject: Fix inference of return clause raising a type error.

---
 pretyping/cases.ml | 54 ++++++++++++++++++++++++++++++------------------------
 1 file changed, 30 insertions(+), 24 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 2a4be9f31c..47d92f5e03 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1865,17 +1865,10 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
 
 (* We put the tycon inside the arity signature, possibly discovering dependencies. *)
 
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) ->
-       (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
-
 let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
   let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
   let subst, len =
-    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
+    List.fold_right2 (fun (tm, tmtype) sign (subst, len) ->
       let signlen = List.length sign in
 	match kind_of_term tm with
 	  | Rel n when dependent tm c
@@ -1886,19 +1879,21 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
 	      (match tmtype with
 		  NotInd _ -> (subst, len - signlen)
 		| IsInd (_, IndType(indf,realargs),_) ->
-		    let subst =
-		      if dependent tm c && List.for_all isRel realargs
-		      then (n, 1) :: subst else subst
-		    in
+		    let subst, len =
 		      List.fold_left
 			(fun (subst, len) arg ->
 			  match kind_of_term arg with
 			  | Rel n when dependent arg c ->
 			      ((n, len) :: subst, pred len)
 			  | _ -> (subst, pred len))
-			(subst, len) realargs)
+			(subst, len) realargs
+		    in
+		    let subst =
+		      if dependent tm c && List.for_all isRel realargs
+		      then (n, len) :: subst else subst
+		    in (subst, pred len))
 	  | _ -> (subst, len - signlen))
-      ([], nar) tomatchs arsign
+      (List.rev tomatchs) arsign ([], nar)
   in
   let rec predicate lift c =
     match kind_of_term c with
@@ -1913,9 +1908,12 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
       | _ ->
 	  map_constr_with_binders succ predicate lift c
   in
+  assert (len == 0);
   let p = predicate 0 c in
-  fst (Typing.type_of (push_rel_context (context_of_arsign arsign) env) sigma p), p
-
+  let env' = List.fold_right push_rel_context arsign env in
+  try let sigma' = fst (Typing.type_of env' sigma p) in
+        Some (sigma', p)
+  with e when precatchable_exception e -> None
 
 (* Builds the predicate. If the predicate is dependent, its context is
  * made of 1+nrealargs assumptions for each matched term in an inductive
@@ -1936,11 +1934,13 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
 	(* If the tycon is not closed w.r.t real variables, we try *)
         (* two different strategies *)
 	(* First strategy: we abstract the tycon wrt to the dependencies *)
-        let sigma1,pred1 =
+        let p1 =
           prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in
 	(* Second strategy: we build an "inversion" predicate *)
 	let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
-	[sigma1, pred1; sigma2, pred2]
+	(match p1 with
+	 | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2]
+	 | None -> [sigma2, pred2])
     | None, _ ->
 	(* No dependent type constraint, or no constraints at all: *)
 	(* we use two strategies *)
@@ -2375,6 +2375,13 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
     assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *)
     arsign'', allnames, nar, eqs, neqs, refls
 
+let context_of_arsign l =
+  let (x, _) = List.fold_right
+    (fun c (x, n) ->
+       (lift_rel_context n c @ x, List.length c + n))
+    l ([], 0)
+  in x
+
 let compile_program_cases loc style (typing_function, evdref) tycon env
     (predopt, tomatchl, eqns) =
   let typing_fun tycon env = function
@@ -2405,12 +2412,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
     | None -> let ev = mkExistential env evdref in ev, ev
     | Some t ->
 	let pred = 
-	  try
-	    let evd, pred = prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t in
-	      evdref := evd; pred
-	  with e when Errors.noncritical e ->
-	    let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in
-	      lift nar t
+	  match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with
+	  | Some (evd, pred) -> evdref := evd; pred
+	  | None ->
+	     let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in
+	       lift nar t
 	in Option.get tycon, pred
   in
   let neqs, arity =
-- 
cgit v1.2.3


From c47b205206d832430fa80a3386be80149e281d33 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Fri, 9 Oct 2015 13:04:56 +0200
Subject: Code cleaning in VM (with Benjamin).

Rename some functions, remove dead code related to (previously deprecated, now
removed) option Set Boxed Values.
---
 pretyping/vnorm.ml | 9 +--------
 1 file changed, 1 insertion(+), 8 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index af640d7f34..f768e4feef 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -179,8 +179,6 @@ and nf_whd env whd typ =
   | Vatom_stk(Aid idkey, stk) ->
       let c,typ = constr_type_of_idkey env idkey in
       nf_stk env c typ stk
-  | Vatom_stk(Aiddef(idkey,v), stk) ->
-      nf_whd env (whd_stack v stk) typ
   | Vatom_stk(Aind ind, stk) ->
       nf_stk env (mkIndU ind) (type_of_ind env ind) stk
 
@@ -312,10 +310,5 @@ and nf_cofix env cf =
   mkCoFix (init,(name,cft,cfb))
 
 let cbv_vm env c t  =
-  let transp = transp_values () in
-  if not transp then set_transp_values true;
   let v = Vconv.val_of_constr env c in
-  let c = nf_val env v t in
-  if not transp then set_transp_values false;
-  c
-
+  nf_val env v t
-- 
cgit v1.2.3


From d399671f3f1a667a47540071feecb20baf115418 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 11 Oct 2015 11:21:23 +0200
Subject: Constr_matching: renaming misleading name stk into ctx.

---
 pretyping/constr_matching.ml | 92 ++++++++++++++++++++++----------------------
 1 file changed, 46 insertions(+), 46 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index a0493777a5..585be9c720 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -80,21 +80,21 @@ let add_binders na1 na2 (names, terms as subst) = match na1, na2 with
     (names, terms)
 | _ -> subst
 
-let rec build_lambda vars stk m = match vars with
+let rec build_lambda vars ctx m = match vars with
 | [] ->
-  let len = List.length stk in
+  let len = List.length ctx in
   lift (-1 * len) m
 | n :: vars ->
   (* change [ x1 ... xn y z1 ... zm |- t ] into
      [ x1 ... xn z1 ... zm |- lam y. t ] *)
-  let len = List.length stk in
+  let len = List.length ctx in
   let init i =
     if i < pred n then mkRel (i + 2)
     else if Int.equal i (pred n) then mkRel 1
     else mkRel (i + 1)
   in
   let m = substl (List.init len init) m in
-  let pre, suf = List.chop (pred n) stk in
+  let pre, suf = List.chop (pred n) ctx in
   match suf with
   | [] -> assert false
   | (_, na, t) :: suf ->
@@ -108,21 +108,21 @@ let rec build_lambda vars stk m = match vars with
     let m = mkLambda (na, t, m) in
     build_lambda vars (pre @ suf) m
 
-let rec extract_bound_aux k accu frels stk = match stk with
+let rec extract_bound_aux k accu frels ctx = match ctx with
 | [] -> accu
-| (na1, na2, _) :: stk ->
+| (na1, na2, _) :: ctx ->
   if Int.Set.mem k frels then
     begin match na1 with
     | Name id ->
       let () = assert (match na2 with Anonymous -> false | Name _ -> true) in
       let () = if Id.Set.mem id accu then raise PatternMatchingFailure in
-      extract_bound_aux (k + 1) (Id.Set.add id accu) frels stk
+      extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx
     | Anonymous -> raise PatternMatchingFailure
     end
-  else extract_bound_aux (k + 1) accu frels stk
+  else extract_bound_aux (k + 1) accu frels ctx
 
-let extract_bound_vars frels stk =
-  extract_bound_aux 1 Id.Set.empty frels stk
+let extract_bound_vars frels ctx =
+  extract_bound_aux 1 Id.Set.empty frels ctx
 
 let dummy_constr = mkProp
 
@@ -134,20 +134,20 @@ let make_renaming ids = function
   end
 | _ -> dummy_constr
 
-let merge_binding allow_bound_rels stk n cT subst =
-  let c = match stk with
+let merge_binding allow_bound_rels ctx n cT subst =
+  let c = match ctx with
   | [] -> (* Optimization *)
     ([], cT)
   | _ ->
     let frels = free_rels cT in
     if allow_bound_rels then
-      let vars = extract_bound_vars frels stk in
+      let vars = extract_bound_vars frels ctx in
       let ordered_vars = Id.Set.elements vars in
       let rename binding = make_renaming ordered_vars binding in
-      let renaming = List.map rename stk in
+      let renaming = List.map rename ctx in
       (ordered_vars, substl renaming cT)
     else
-      let depth = List.length stk in
+      let depth = List.length ctx in
       let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in
       if depth < min_elt then
         ([], lift (- depth) cT)
@@ -168,7 +168,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 	    is_conv env sigma c' c
        else false)
   in
-  let rec sorec stk env subst p t =
+  let rec sorec ctx env subst p t =
     let cT = strip_outer_cast t in
     match p,kind_of_term cT with
       | PSoApp (n,args),m ->
@@ -181,11 +181,11 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
         let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in
         let frels = free_rels cT in
         if Int.Set.subset frels relset then
-          constrain n ([], build_lambda relargs stk cT) subst
+          constrain n ([], build_lambda relargs ctx cT) subst
         else
           raise PatternMatchingFailure
 
-      | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst
+      | PMeta (Some n), m -> merge_binding allow_bound_rels ctx n cT subst
 
       | PMeta None, m -> subst
 
@@ -203,10 +203,10 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 
       | PSort (GType _), Sort (Type _) -> subst
 
-      | PApp (p, [||]), _ -> sorec stk env subst p t
+      | PApp (p, [||]), _ -> sorec ctx env subst p t
 
       | PApp (PApp (h, a1), a2), _ ->
-          sorec stk env subst (PApp(h,Array.append a1 a2)) t
+          sorec ctx env subst (PApp(h,Array.append a1 a2)) t
 
       | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app ->
          (let diff = Array.length args2 - Array.length args1 in
@@ -216,13 +216,13 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
             let subst =
               match meta with
               | None -> subst
-              | Some n -> merge_binding allow_bound_rels stk n c subst in
-            Array.fold_left2 (sorec stk env) subst args1 args22
+              | Some n -> merge_binding allow_bound_rels ctx n c subst in
+            Array.fold_left2 (sorec ctx env) subst args1 args22
           else (* Might be a projection on the right *)
 	    match kind_of_term c2 with
 	    | Proj (pr, c) when not (Projection.unfolded pr) ->
 	      (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in
-		     sorec stk env subst p term
+		     sorec ctx env subst p term
 	       with Retyping.RetypeError _ -> raise PatternMatchingFailure)
 	    | _ -> raise PatternMatchingFailure)
 	   
@@ -233,15 +233,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 	  raise PatternMatchingFailure
 	| PProj (pr1,c1), Proj (pr,c) ->
 	  if Projection.equal pr1 pr then 
-	    try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c) arg1 arg2
+	    try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2
 	    with Invalid_argument _ -> raise PatternMatchingFailure
 	  else raise PatternMatchingFailure
 	| _, Proj (pr,c) when not (Projection.unfolded pr) ->
 	  (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in
-		 sorec stk env subst p term
+		 sorec ctx env subst p term
 	   with Retyping.RetypeError _ -> raise PatternMatchingFailure)	    
 	| _, _ ->
-          try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c2) arg1 arg2
+          try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2
           with Invalid_argument _ -> raise PatternMatchingFailure)
 	  
       | PApp (PRef (ConstRef c1), _), Proj (pr, c2) 
@@ -250,37 +250,37 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 	
       | PApp (c, args), Proj (pr, c2) ->
 	(try let term = Retyping.expand_projection env sigma pr c2 [] in
-	       sorec stk env subst p term
+	       sorec ctx env subst p term
 	 with Retyping.RetypeError _ -> raise PatternMatchingFailure)
 
       | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 ->
-          sorec stk env subst c1 c2
+          sorec ctx env subst c1 c2
 
       | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env)
-            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
 
       | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env)
-            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
 
       | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
-	  sorec ((na1,na2,t2)::stk) (Environ.push_rel (na2,Some c2,t2) env)
-            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
+            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
-	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
-	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
-	  let n = rel_context_length ctx in
-          let n' = rel_context_length ctx' in
+	  let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
+	  let ctx_b2',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
+	  let n = rel_context_length ctx_b2 in
+          let n' = rel_context_length ctx_b2' in
 	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
-	    let s =
-	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in
-	    let s' =
-	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in
+            let f l (na,_,t) = (Anonymous,na,t)::l in
+	    let ctx_br = List.fold_left f ctx ctx_b2 in
+	    let ctx_br' = List.fold_left f ctx ctx_b2' in
 	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
-	    sorec s' (Environ.push_rel_context ctx' env)
-	      (sorec s (Environ.push_rel_context ctx env) (sorec stk env subst a1 a2) b1 b2) b1' b2'
+	    sorec ctx_br' (Environ.push_rel_context ctx_b2' env)
+	      (sorec ctx_br (Environ.push_rel_context ctx_b2 env)
+                 (sorec ctx env subst a1 a2) b1 b2) b1' b2'
           else
             raise PatternMatchingFailure
 
@@ -301,9 +301,9 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 	    (* (ind,j+1) is normally known to be a correct constructor
 	       and br2 a correct match over the same inductive *)
 	    assert (j < n2);
-	    sorec stk env subst c br2.(j)
+	    sorec ctx env subst c br2.(j)
 	  in
-	  let chk_head = sorec stk env (sorec stk env subst a1 a2) p1 p2 in
+	  let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in
 	  List.fold_left chk_branch chk_head br1
 
       |	PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst
-- 
cgit v1.2.3


From 2e07ecfce221840047b2f95c93acdb79a4fe0985 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 11 Oct 2015 13:42:11 +0200
Subject: Fixing obviously untested fold_glob_constr and iter_glob_constr.

---
 pretyping/glob_ops.ml | 51 +++++++++++++++++++++++----------------------------
 1 file changed, 23 insertions(+), 28 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 454d64f01b..5b02c8cd15 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -183,37 +183,32 @@ let map_glob_constr_left_to_right f = function
 
 let map_glob_constr = map_glob_constr_left_to_right
 
-let fold_glob_constr f acc =
-  let rec fold acc = function
+let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt
+
+let fold_glob_constr f acc = function
   | GVar _ -> acc
-  | GApp (_,c,args) -> List.fold_left fold (fold acc c) args
+  | GApp (_,c,args) -> List.fold_left f (f acc c) args
   | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) ->
-      fold (fold acc b) c
+    f (f acc b) c
   | GCases (_,_,rtntypopt,tml,pl) ->
-      List.fold_left fold_pattern
-	(List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml))
-	pl
-    | GLetTuple (_,_,rtntyp,b,c) ->
-	fold (fold (fold_return_type acc rtntyp) b) c
-    | GIf (_,c,rtntyp,b1,b2) ->
-	fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2
-    | GRec (_,_,_,bl,tyl,bv) ->
-	let acc = Array.fold_left
-	  (List.fold_left (fun acc (na,k,bbd,bty) ->
-	    fold (Option.fold_left fold acc bbd) bty)) acc bl in
-	Array.fold_left fold (Array.fold_left fold acc tyl) bv
-    | GCast (_,c,k) ->
-        let r = match k with
-        | CastConv t | CastVM t | CastNative t -> fold acc t | CastCoerce -> acc
-        in
-        fold r c
-    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
-
-  and fold_pattern acc (_,idl,p,c) = fold acc c
-
-  and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt
-
-  in fold acc
+    let fold_pattern acc (_,idl,p,c) = f acc c in
+    List.fold_left fold_pattern
+      (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml))
+      pl
+  | GLetTuple (_,_,rtntyp,b,c) ->
+    f (f (fold_return_type f acc rtntyp) b) c
+  | GIf (_,c,rtntyp,b1,b2) ->
+    f (f (f (fold_return_type f acc rtntyp) c) b1) b2
+  | GRec (_,_,_,bl,tyl,bv) ->
+    let acc = Array.fold_left
+      (List.fold_left (fun acc (na,k,bbd,bty) ->
+	f (Option.fold_left f acc bbd) bty)) acc bl in
+    Array.fold_left f (Array.fold_left f acc tyl) bv
+  | GCast (_,c,k) ->
+    let acc = match k with
+      | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in
+    f acc c
+  | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
 
 let iter_glob_constr f = fold_glob_constr (fun () -> f) ()
 
-- 
cgit v1.2.3


From ae5305a4837cce3c7fd61b92ce8110ac66ec2750 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 11 Oct 2015 15:05:10 +0200
Subject: Refining 0c320e79ba30 in fixing interpretation of constr under
 binders which was broken after it became possible to have binding names
 themselves bound to ltac variables (2fcc458af16b).

Interpretation was corrected, but error message was damaged.
---
 pretyping/pretyping.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 6306739b7a..746b4000ee 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -322,8 +322,8 @@ let ltac_interp_name_env k0 lvar env =
   push_rel_context ctxt env
 
 let invert_ltac_bound_name lvar env id0 id =
-  let id = Id.Map.find id lvar.ltac_idents in
-  try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+  let id' = Id.Map.find id lvar.ltac_idents in
+  try mkRel (pi1 (lookup_rel_id id' (rel_context env)))
   with Not_found ->
     errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
 		       str " depends on pattern variable name " ++ pr_id id ++
-- 
cgit v1.2.3


From e9995f6e9f9523d4738d9ee494703b6f96bf995d Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 11 Oct 2015 14:36:29 +0200
Subject: Fixing untimely unexpected warning "Collision between bound
 variables" (#4317).

Collecting the bound variables is now done on the glob_constr, before
interpretation, so that only variables given explicitly by the user
are used for binding bound variables.
---
 pretyping/constr_matching.ml  | 46 ++++++++++++++++-----------------
 pretyping/constr_matching.mli |  9 ++++---
 pretyping/glob_ops.ml         | 60 +++++++++++++++++++++++++++++++++++++++++++
 pretyping/glob_ops.mli        |  1 +
 4 files changed, 90 insertions(+), 26 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 585be9c720..19c85c9e27 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -56,10 +56,6 @@ let warn_bound_meta name =
 let warn_bound_bound name =
   msg_warning (str "Collision between bound variables of name " ++ pr_id name)
 
-let warn_bound_again name =
-  msg_warning (str "Collision between bound variable " ++ pr_id name ++
-    str " and another bound variable of same name.")
-
 let constrain n (ids, m as x) (names, terms as subst) =
   try
     let (ids', m') = Id.Map.find n terms in
@@ -69,16 +65,17 @@ let constrain n (ids, m as x) (names, terms as subst) =
     let () = if Id.Map.mem n names then warn_bound_meta n in
     (names, Id.Map.add n x terms)
 
-let add_binders na1 na2 (names, terms as subst) = match na1, na2 with
-| Name id1, Name id2 ->
-  if Id.Map.mem id1 names then
-    let () = warn_bound_bound id1 in
-    (names, terms)
-  else
-    let names = Id.Map.add id1 id2 names in
-    let () = if Id.Map.mem id1 terms then warn_bound_again id1 in
-    (names, terms)
-| _ -> subst
+let add_binders na1 na2 binding_vars (names, terms as subst) =
+  match na1, na2 with
+  | Name id1, Name id2 when Id.Set.mem id1 binding_vars ->
+    if Id.Map.mem id1 names then
+      let () = warn_bound_bound id1 in
+      (names, terms)
+    else
+      let names = Id.Map.add id1 id2 names in
+      let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in
+      (names, terms)
+  | _ -> subst
 
 let rec build_lambda vars ctx m = match vars with
 | [] ->
@@ -155,7 +152,8 @@ let merge_binding allow_bound_rels ctx n cT subst =
   in
   constrain n c subst
       
-let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
+let matches_core env sigma convert allow_partial_app allow_bound_rels
+    (binding_vars,pat) c =
   let convref ref c = 
     match ref, kind_of_term c with
     | VarRef id, Var id' -> Names.id_eq id id'
@@ -258,15 +256,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
 
       | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
 	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
-            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
+            (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
 	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
-            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
+            (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
 	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
-            (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2
+            (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
 	  let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
@@ -319,7 +317,8 @@ let matches_core_closed env sigma convert allow_partial_app pat c =
 
 let extended_matches env sigma = matches_core env sigma false true true
 
-let matches env sigma pat c = snd (matches_core_closed env sigma false true pat c)
+let matches env sigma pat c =
+  snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c)
 
 let special_meta = (-1)
 
@@ -464,10 +463,10 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
   let result () = aux env c (fun x -> x) lempty in
   IStream.thunk result
 
-let match_subterm env sigma pat c = sub_match env sigma pat c
+let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c
 
 let match_appsubterm env sigma pat c = 
-  sub_match ~partial_app:true env sigma pat c
+  sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c
 
 let match_subterm_gen env sigma app pat c = 
   sub_match ~partial_app:app env sigma pat c
@@ -481,11 +480,12 @@ let is_matching_head env sigma pat c =
   with PatternMatchingFailure -> false
 
 let is_matching_appsubterm ?(closed=true) env sigma pat c =
+  let pat = (Id.Set.empty,pat) in
   let results = sub_match ~partial_app:true ~closed env sigma pat c in
   not (IStream.is_empty results)
 
-let matches_conv env sigma c p =
-  snd (matches_core_closed env sigma true false c p)
+let matches_conv env sigma p c =
+  snd (matches_core_closed env sigma true false (Id.Set.empty,p) c)
 
 let is_matching_conv env sigma pat n =
   try let _ = matches_conv env sigma pat n in true
diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli
index 67854a893d..b9dcb0af26 100644
--- a/pretyping/constr_matching.mli
+++ b/pretyping/constr_matching.mli
@@ -41,7 +41,8 @@ val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
    variables or metavariables have the same name, the metavariable,
    or else the rightmost bound variable, takes precedence *)
 val extended_matches :
-  env -> Evd.evar_map -> constr_pattern -> constr -> bound_ident_map * extended_patvar_map
+  env -> Evd.evar_map -> Tacexpr.binding_bound_vars * constr_pattern ->
+  constr -> bound_ident_map * extended_patvar_map
 
 (** [is_matching pat c] just tells if [c] matches against [pat] *)
 val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool
@@ -72,8 +73,10 @@ val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_
 val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
 
 (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) ->
-   constr_pattern -> constr -> matching_result IStream.t
+val match_subterm_gen : env -> Evd.evar_map ->
+  bool (** true = with app context *) ->
+  Tacexpr.binding_bound_vars * constr_pattern -> constr ->
+  matching_result IStream.t
 
 (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches
    against [pat] taking partial subterms into consideration *)
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 5b02c8cd15..3a76e8bd74 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -8,6 +8,7 @@
 
 open Util
 open Names
+open Nameops
 open Globnames
 open Misctypes
 open Glob_term
@@ -323,6 +324,65 @@ let free_glob_vars  =
     let vs = vars Id.Set.empty Id.Set.empty rt in
     Id.Set.elements vs
 
+let add_and_check_ident id set =
+  if Id.Set.mem id set then
+    Pp.(msg_warning
+      (str "Collision between bound variables of name " ++ Id.print id));
+  Id.Set.add id set
+
+let bound_glob_vars =
+  let rec vars bound = function
+    | GLambda (_,na,_,_,_) | GProd (_,na,_,_,_) | GLetIn (_,na,_,_) as c ->
+        let bound = name_fold add_and_check_ident na bound in
+        fold_glob_constr vars bound c
+    | GCases (loc,sty,rtntypopt,tml,pl) ->
+	let bound = vars_option bound rtntypopt in
+	let bound =
+          List.fold_left (fun bound (tm,_) -> vars bound tm) bound tml in
+	List.fold_left vars_pattern bound pl
+    | GLetTuple (loc,nal,rtntyp,b,c) ->
+	let bound = vars_return_type bound rtntyp in
+	let bound = vars bound b in
+	let bound = List.fold_right (name_fold add_and_check_ident) nal bound in
+	vars bound c
+    | GIf (loc,c,rtntyp,b1,b2) ->
+	let bound = vars_return_type bound rtntyp in
+	let bound = vars bound c in
+	let bound = vars bound b1 in
+	vars bound b2
+    | GRec (loc,fk,idl,bl,tyl,bv) ->
+	let bound = Array.fold_right Id.Set.add idl bound in
+	let vars_fix i bound fid =
+	  let bound =
+	    List.fold_left
+	      (fun bound (na,k,bbd,bty) ->
+		 let bound = vars_option bound bbd in
+		 let bound = vars bound bty in
+		 name_fold add_and_check_ident na bound
+	      )
+	      bound
+	      bl.(i)
+	  in
+	  let bound = vars bound tyl.(i) in
+	  vars bound bv.(i)
+	in
+	Array.fold_left_i vars_fix bound idl
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GVar _) -> bound
+    | GApp _ | GCast _ as c -> fold_glob_constr vars bound c
+
+  and vars_pattern bound (loc,idl,p,c) =
+    let bound = List.fold_right add_and_check_ident idl bound in
+    vars bound c
+
+  and vars_option bound = function None -> bound | Some p -> vars bound p
+
+  and vars_return_type bound (na,tyopt) =
+    let bound = name_fold add_and_check_ident na bound in
+    vars_option bound tyopt
+  in
+  fun rt ->
+    vars Id.Set.empty rt
+
 (** Mapping of names in binders *)
 
 (* spiwack: I used a smartmap-style kind of mapping here, because the
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index e514fd529e..25746323fb 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -38,6 +38,7 @@ val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
 val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
 val occur_glob_constr : Id.t -> glob_constr -> bool
 val free_glob_vars : glob_constr -> Id.t list
+val bound_glob_vars : glob_constr -> Id.Set.t
 val loc_of_glob_constr : glob_constr -> Loc.t
 
 (** [map_pattern_binders f m c] applies [f] to all the binding names
-- 
cgit v1.2.3


From a479aa6e8dbd1dda1af2412f8c1e1ff40f0d5a0b Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 12 Oct 2015 12:57:23 +0200
Subject: Fix rechecking of applications: it can be given ill-typed terms.
 Fixes math-classes.

---
 pretyping/evarsolve.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index a2189d5e4f..754ad8f588 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -130,6 +130,8 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd =
 
 (* We retype applications to ensure the universe constraints are collected *)
 
+exception IllTypedInstance of env * types * types
+
 let recheck_applications conv_algo env evdref t =
   let rec aux env t =
     match kind_of_term t with
@@ -146,7 +148,7 @@ let recheck_applications conv_algo env evdref t =
 			     aux (succ i) (subst1 args.(i) codom)
 	     | UnifFailure (evd, reason) ->
 		Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom))
-	 | _ -> assert false
+	 | _ -> raise (IllTypedInstance (env, ty, argsty.(i)))
        else ()
      in aux 0 fty
     | _ ->
@@ -1134,8 +1136,6 @@ let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (e
   else
     raise (CannotProject (evd,ev1'))
 
-exception IllTypedInstance of env * types * types
-
 let check_evar_instance evd evk1 body conv_algo =
   let evi = Evd.find evd evk1 in
   let evenv = evar_env evi in
-- 
cgit v1.2.3


From ed95f122f3c68becc09c653471dc2982b346d343 Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Tue, 13 Oct 2015 18:30:47 +0200
Subject: Fix some typos.

---
 pretyping/evarutil.ml | 2 +-
 pretyping/tacred.ml   | 6 +++---
 pretyping/termops.ml  | 2 +-
 3 files changed, 5 insertions(+), 5 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 8ebb037c24..d3d6901b66 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -525,7 +525,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
 let clear_hyps_in_evi_main env evdref hyps terms ids =
   (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
      hypothesis does not depend on a element of ids, and erases ids in
-     the contexts of the evars occuring in evi *)
+     the contexts of the evars occurring in evi *)
   let terms =
     List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
   let nhyps =
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 8a5db90590..48911a5a9f 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -1011,8 +1011,8 @@ let contextually byhead occs f env sigma t =
     snd (e_contextually byhead occs f' env sigma t)
 
 (* linear bindings (following pretty-printer) of the value of name in c.
- * n is the number of the next occurence of name.
- * ol is the occurence list to find. *)
+ * n is the number of the next occurrence of name.
+ * ol is the occurrence list to find. *)
 
 let match_constr_evaluable_ref sigma c evref = 
   match kind_of_term c, evref with
@@ -1061,7 +1061,7 @@ let is_projection env = function
 
 (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
  * Unfolds the constant name in a term c following a list of occurrences occl.
- * at the occurrences of occ_list. If occ_list is empty, unfold all occurences.
+ * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences.
  * Performs a betaiota reduction after unfolding. *)
 let unfoldoccs env sigma (occs,name) c =
   let unfo nowhere_except_in locs =
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 937471cf76..5a55d47fd1 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -561,7 +561,7 @@ let free_rels m =
   in
   frec 1 Int.Set.empty m
 
-(* collects all metavar occurences, in left-to-right order, preserving
+(* collects all metavar occurrences, in left-to-right order, preserving
  * repetitions and all. *)
 
 let collect_metas c =
-- 
cgit v1.2.3


From 4b8155591be6e20505ee25f7199edcf44a638c7e Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 14 Oct 2015 14:38:22 +0200
Subject: Fixing evarmap implementation.

---
 pretyping/evd.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 3d912ca4ce..1107c2951e 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -750,7 +750,7 @@ let cmap f evd =
   { evd with
       metas = Metamap.map (map_clb f) evd.metas;
       defn_evars = EvMap.map (map_evar_info f) evd.defn_evars;
-      undf_evars = EvMap.map (map_evar_info f) evd.defn_evars
+      undf_evars = EvMap.map (map_evar_info f) evd.undf_evars
   }
 
 (* spiwack: deprecated *)
-- 
cgit v1.2.3


From b8c681338cad546c397a1803c55183cc6526adfb Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 14 Oct 2015 16:39:09 +0200
Subject: Fix constr_matching when a match is found in the head of a case
 construct

---
 pretyping/constr_matching.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 19c85c9e27..121ab74885 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -415,8 +415,8 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
           try_aux sub mk_ctx next
   | Case (ci,hd,c1,lc) ->
       let next_mk_ctx = function
-      | [] -> assert false
-      | c1 :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
+      | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
+      | _ -> assert false
       in
       let sub = (env, c1) :: (env, hd) :: subargs env lc in
       try_aux sub next_mk_ctx next
-- 
cgit v1.2.3


From 26af31cb46c7baf92325dd22bf6ee33aaa2172d2 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 14 Oct 2015 18:17:42 +0200
Subject: Occur-check in evar_define was not strong enough.

---
 pretyping/evarsolve.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 754ad8f588..bbc4f1db29 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1484,7 +1484,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
     if occur_meta body then raise MetaOccurInBodyInternal;
     (* invert_definition may have instantiate some evars of rhs with evk *)
     (* so we recheck acyclicity *)
-    if occur_evar evk body then raise (OccurCheckIn (evd',body));
+    if occur_evar_upto evd' evk body then raise (OccurCheckIn (evd',body));
     (* needed only if an inferred type *)
     let evd', body = refresh_universes pbty env evd' body in
 (* Cannot strictly type instantiations since the unification algorithm
-- 
cgit v1.2.3


From 3116aeff0cdc51e6801f3e8ae4a6c0533e1a75ac Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Thu, 8 Oct 2015 18:06:55 +0200
Subject: Fix #4346 1/2: native casts were not inferring universe constraints.

---
 pretyping/nativenorm.ml    | 20 ++++++++++++++------
 pretyping/nativenorm.mli   |  6 ++++--
 pretyping/pretyping.ml     |  8 +++-----
 pretyping/reductionops.ml  | 11 +++++++----
 pretyping/reductionops.mli |  9 ++++++++-
 5 files changed, 36 insertions(+), 18 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 2432b8d291..949a28a1f4 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -22,11 +22,6 @@ open Nativelambda
 
 (** This module implements normalization by evaluation to OCaml code *)
 
-let evars_of_evar_map evd =
-  { evars_val = Evd.existential_opt_value evd;
-    evars_typ = Evd.existential_type evd;
-    evars_metas = Evd.meta_type evd }
-
 exception Find_at of int
 
 let invert_tag cst tag reloc_tbl =
@@ -375,11 +370,17 @@ and  nf_predicate env ind mip params v pT =
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_type env v
 
+let evars_of_evar_map sigma =
+  { Nativelambda.evars_val = Evd.existential_opt_value sigma;
+    Nativelambda.evars_typ = Evd.existential_type sigma;
+    Nativelambda.evars_metas = Evd.meta_type sigma }
+
 let native_norm env sigma c ty =  
   if Coq_config.no_native_compiler then
     error "Native_compute reduction has been disabled at configure time."
   else
-  let penv = Environ.pre_env env in 
+  let penv = Environ.pre_env env in
+  let sigma = evars_of_evar_map sigma in
   (*
   Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1);
   Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2);
@@ -400,3 +401,10 @@ let native_norm env sigma c ty =
         if !Flags.debug then Pp.msg_debug (Pp.str time_info);
         res
     | _ -> anomaly (Pp.str "Compilation failure") 
+
+let native_conv_generic pb sigma t =
+  Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t
+
+let native_infer_conv ?(pb=Reduction.CUMUL) env sigma x y =
+  Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma)
+    ~catch_incon:true ~pb env sigma x y
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index c854e8c9c5..0352038385 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -12,6 +12,8 @@ open Nativelambda
 
 (** This module implements normalization by evaluation to OCaml code *)
 
-val evars_of_evar_map : evar_map -> evars
+val native_norm : env -> evar_map -> constr -> types -> constr
 
-val native_norm : env -> evars -> constr -> types -> constr
+(** Conversion with inference of universe constraints *)
+val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr ->
+  evar_map * bool
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 746b4000ee..e1e8982e1e 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -942,12 +942,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	  | NATIVEcast ->
  	    let cj = pretype empty_tycon env evdref lvar c in
 	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
-            let evars = Nativenorm.evars_of_evar_map !evdref in
-	    let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in 
             begin
-              try
-                ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj
-              with Reduction.NotConvertible -> 
+	      let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in
+	      if b then (evdref := evd; cj)
+	      else
                 error_actual_type_loc loc env !evdref cj tval 
                   (ConversionFailed (env,cty,tval))
             end
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index dc70f36ccf..a24773b6e6 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1295,8 +1295,8 @@ let sigma_univ_state =
   { Reduction.compare = sigma_compare_sorts;
     Reduction.compare_instances = sigma_compare_instances }
 
-let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) 
-    env sigma x y = 
+let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
+    ?(ts=full_transparent_state) env sigma x y =
   try 
     let b, sigma = 
       let b, cstrs = 
@@ -1313,14 +1313,17 @@ let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_s
       if b then sigma, true
       else
 	let sigma' = 
-	  Reduction.generic_conv pb false (safe_evar_value sigma) ts 
+	  conv_fun pb ~l2r:false sigma ts
 	    env (sigma, sigma_univ_state) x y in
 	  sigma', true
   with
   | Reduction.NotConvertible -> sigma, false
   | Univ.UniverseInconsistency _ when catch_incon -> sigma, false
   | e when is_anomaly e -> error "Conversion test raised an anomaly"
-    
+
+let infer_conv = infer_conv_gen (fun pb ~l2r sigma ->
+      Reduction.generic_conv pb ~l2r (safe_evar_value sigma))
+
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 1df2a73b2e..b179dbc95e 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -266,7 +266,7 @@ val is_trans_fconv : conv_pb -> transparent_state -> env ->  evar_map -> constr
  *)
 val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env ->  evar_map -> constr -> constr -> bool
 
-(** [infer_fconv] Adds necessary universe constraints to the evar map.
+(** [infer_conv] Adds necessary universe constraints to the evar map.
     pb defaults to CUMUL and ts to a full transparent state.
     @raises UniverseInconsistency iff catch_incon is set to false, 
     otherwise returns false in that case.
@@ -274,6 +274,13 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env ->  evar_map -> con
 val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> 
   env -> evar_map -> constr -> constr -> evar_map * bool
 
+(** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a
+conversion function. Used to pretype vm and native casts. *)
+val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state ->
+    (constr, evar_map) Reduction.generic_conversion_function) ->
+  ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env ->
+  evar_map -> constr -> constr -> evar_map * bool
+
 (** {6 Special-Purpose Reduction Functions } *)
 
 val whd_meta : evar_map -> constr -> constr
-- 
cgit v1.2.3


From 44817bf722eacb0379bebc7e435bfafa503d574f Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Thu, 15 Oct 2015 14:21:45 +0200
Subject:  Fix #4346 2/2: VM casts were not inferring universe constraints.

---
 pretyping/nativenorm.ml    |  4 ++--
 pretyping/pretyping.ml     | 11 ++++-------
 pretyping/reductionops.ml  |  3 ---
 pretyping/reductionops.mli |  2 --
 pretyping/vnorm.ml         |  4 ++++
 pretyping/vnorm.mli        |  4 ++++
 6 files changed, 14 insertions(+), 14 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 949a28a1f4..dafe88d8db 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -405,6 +405,6 @@ let native_norm env sigma c ty =
 let native_conv_generic pb sigma t =
   Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t
 
-let native_infer_conv ?(pb=Reduction.CUMUL) env sigma x y =
+let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 =
   Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma)
-    ~catch_incon:true ~pb env sigma x y
+    ~catch_incon:true ~pb env sigma t1 t2
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index e1e8982e1e..f6c1867285 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -929,14 +929,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
  	    let cj = pretype empty_tycon env evdref lvar c in
 	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
 	      if not (occur_existential cty || occur_existential tval) then
-		begin 
-		  try
-		    let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in 
-		    ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
-		  with Reduction.NotConvertible -> 
-		    error_actual_type_loc loc env !evdref cj tval 
+		let (evd,b) = Vnorm.vm_infer_conv env !evdref cty tval in
+		if b then (evdref := evd; cj)
+		else
+		  error_actual_type_loc loc env !evdref cj tval 
                       (ConversionFailed (env,cty,tval))
-		end
 	      else user_err_loc (loc,"",str "Cannot check cast with vm: " ++
 		str "unresolved arguments remain.")
 	  | NATIVEcast ->
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index a24773b6e6..d25e273a3e 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1251,9 +1251,6 @@ let pb_equal = function
   | Reduction.CUMUL -> Reduction.CONV
   | Reduction.CONV -> Reduction.CONV
 
-let sort_cmp cv_pb s1 s2 u = 
-  Reduction.check_sort_cmp_universes cv_pb s1 s2 u
-
 let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
   try
     let evars ev = safe_evar_value sigma ev in
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index b179dbc95e..42c2c9c6e6 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -251,8 +251,6 @@ type conversion_test = constraints -> constraints
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
-val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit
-
 val is_conv : env ->  evar_map -> constr -> constr -> bool
 val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
 val is_fconv : conv_pb -> env ->  evar_map -> constr -> constr -> bool
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index f768e4feef..2c6ac7a292 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -312,3 +312,7 @@ and nf_cofix env cf =
 let cbv_vm env c t  =
   let v = Vconv.val_of_constr env c in
   nf_val env v t
+
+let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 =
+  Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb)
+    ~catch_incon:true ~pb env sigma t1 t2
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 7dabbc6cb0..99856a8d9a 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -8,7 +8,11 @@
 
 open Term
 open Environ
+open Evd
 
 (** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
 
+(** Conversion with inference of universe constraints *)
+val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr ->
+  evar_map * bool
-- 
cgit v1.2.3


From 048b87502eced0a46a654f3f95de8f1968004db1 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Thu, 15 Oct 2015 18:15:21 +0200
Subject: Avoid dependency of the pretyper on C code.

Using the same hack as in the kernel: VM conversion is a reference to
a function, updated when modules using C code are actually linked.

This hack should one day go away, but always linking C code may produce some
other trouble (with the OCaml debugger for instance), so better be safe
for now.
---
 pretyping/pretyping.ml     | 2 +-
 pretyping/reductionops.ml  | 6 ++++++
 pretyping/reductionops.mli | 7 +++++++
 pretyping/vnorm.ml         | 2 ++
 pretyping/vnorm.mli        | 4 ----
 5 files changed, 16 insertions(+), 5 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index f6c1867285..d484df69c1 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -929,7 +929,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
  	    let cj = pretype empty_tycon env evdref lvar c in
 	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
 	      if not (occur_existential cty || occur_existential tval) then
-		let (evd,b) = Vnorm.vm_infer_conv env !evdref cty tval in
+		let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in
 		if b then (evdref := evd; cj)
 		else
 		  error_actual_type_loc loc env !evdref cj tval 
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index d25e273a3e..bb1bc7d2ea 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1321,6 +1321,12 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
 let infer_conv = infer_conv_gen (fun pb ~l2r sigma ->
       Reduction.generic_conv pb ~l2r (safe_evar_value sigma))
 
+(* This reference avoids always having to link C code with the kernel *)
+let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:full_transparent_state)
+let set_vm_infer_conv f = vm_infer_conv := f
+let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 =
+  !vm_infer_conv ~pb env t1 t2
+
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 42c2c9c6e6..d5a844847c 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -272,6 +272,13 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env ->  evar_map -> con
 val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> 
   env -> evar_map -> constr -> constr -> evar_map * bool
 
+(** Conversion with inference of universe constraints *)
+val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr ->
+  evar_map * bool) -> unit
+val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr ->
+  evar_map * bool
+
+
 (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a
 conversion function. Used to pretype vm and native casts. *)
 val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state ->
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 2c6ac7a292..46af784dda 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -316,3 +316,5 @@ let cbv_vm env c t  =
 let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 =
   Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb)
     ~catch_incon:true ~pb env sigma t1 t2
+
+let _ = Reductionops.set_vm_infer_conv vm_infer_conv
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 99856a8d9a..9421b2d859 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -12,7 +12,3 @@ open Evd
 
 (** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
-
-(** Conversion with inference of universe constraints *)
-val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr ->
-  evar_map * bool
-- 
cgit v1.2.3


From 23545b802a14b2fad10f4382604c71f55b7d6d0e Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 18 Oct 2015 19:44:49 +0200
Subject: Using appropriate lambda decomposition function counting let-ins when
 dealing with "match".

Contrastingly, "fix" is considered not to count let-ins for finding
the recursive argument (which is ok because the last argument is
necessarily a lambda).
---
 pretyping/cases.ml           | 5 +++--
 pretyping/constr_matching.ml | 4 ++--
 pretyping/detyping.ml        | 2 +-
 3 files changed, 6 insertions(+), 5 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 47d92f5e03..a5a7ace221 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1077,7 +1077,7 @@ let rec ungeneralize n ng body =
         let p = prod_applist p [mkRel (n+List.length sign+ng)] in
         it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in
       mkCase (ci,p,c,Array.map2 (fun q c ->
-        let sign,b = decompose_lam_n_assum q c in
+        let sign,b = decompose_lam_n_decls q c in
         it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign)
         ci.ci_cstr_ndecls brs)
   | App (f,args) ->
@@ -1102,7 +1102,8 @@ let rec is_dependent_generalization ng body =
   | Case (ci,p,c,brs) ->
       (* We traverse a split *)
       Array.exists2 (fun q c ->
-        let _,b = decompose_lam_n_assum q c in is_dependent_generalization ng b)
+        let _,b = decompose_lam_n_decls q c in
+        is_dependent_generalization ng b)
         ci.ci_cstr_ndecls brs
   | App (g,args) ->
       (* We traverse an inner generalization *)
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 121ab74885..5e99521a12 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -267,8 +267,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
-	  let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
-	  let ctx_b2',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
+	  let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in
+	  let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in
 	  let n = rel_context_length ctx_b2 in
           let n' = rel_context_length ctx_b2' in
 	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index a1213e72be..87f2550240 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -302,7 +302,7 @@ and contract_branch isgoal e (cdn,can,mkpat,b) =
 let is_nondep_branch c l =
   try
     (* FIXME: do better using tags from l *)
-    let sign,ccl = decompose_lam_n_assum (List.length l) c in
+    let sign,ccl = decompose_lam_n_decls (List.length l) c in
     noccur_between 1 (rel_context_length sign) ccl
   with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
     false
-- 
cgit v1.2.3


From 8748947349a206a502e43cfe70e3397ee457c4f7 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 17 Oct 2015 17:26:38 +0200
Subject: Fixing #4198 (continued): not matching within the inner
 lambdas/let-ins of the return clause and of the branches (what assumed that
 the implementation preserves the invariant that the return predicate and the
 branches are in canonical [fun Δ => t] form, with Δ possibly containing
 let-ins).

---
 pretyping/constr_matching.ml | 19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 5e99521a12..3fa037ffdd 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -413,12 +413,25 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
             mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
           let sub = (env, c1) :: subargs env lc in
           try_aux sub mk_ctx next
-  | Case (ci,hd,c1,lc) ->
+  | Case (ci,p,c,brs) ->
+      (* Warning: this assumes predicate and branches to be
+         in canonical form using let and fun of the signature *)
+      let nardecls = List.length ci.ci_pp_info.ind_tags in
+      let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in
+      let env_p = Environ.push_rel_context sign_p env in
+      let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in
+      let sign_brs = Array.map fst brs in
+      let f (sign,br) = (Environ.push_rel_context sign env, br) in
+      let sub_br = Array.map f brs in
       let next_mk_ctx = function
-      | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
+      | c :: p :: brs ->
+        let p = it_mkLambda_or_LetIn p sign_p in
+        let brs =
+          Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in
+        mk_ctx (mkCase (ci,p,c,brs))
       | _ -> assert false
       in
-      let sub = (env, c1) :: (env, hd) :: subargs env lc in
+      let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in
       try_aux sub next_mk_ctx next
   | Fix (indx,(names,types,bodies)) ->
     let nb_fix = Array.length types in
-- 
cgit v1.2.3


From c70ee60ed1603658eb33f4ae39b1a0be81bf45c6 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 17 Oct 2015 17:29:19 +0200
Subject: Using "__" rather than this unelegant arbitrary "A" for the name of
 variables of the context of an evar in debugging mode.

---
 pretyping/detyping.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 87f2550240..b5228094a2 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -513,7 +513,7 @@ let rec detype flags avoid env sigma t =
           id,l
         with Not_found ->
           Id.of_string ("X" ^ string_of_int (Evar.repr evk)), 
-          (Array.map_to_list (fun c -> (Id.of_string "A",c)) cl)
+          (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl)
       in
         GEvar (dl,id,
                List.map (on_snd (detype flags avoid env sigma)) l)
-- 
cgit v1.2.3


From 7d697193ab175b6bfa3c773880c0a06348449d19 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 18 Oct 2015 20:29:58 +0200
Subject: Making Evarutil.new_evar monotonous.

---
 pretyping/evarconv.ml    |  5 ++++-
 pretyping/evarutil.ml    | 15 ++++++++++-----
 pretyping/evarutil.mli   |  4 ++--
 pretyping/unification.ml | 27 ++++++++++++++++-----------
 4 files changed, 32 insertions(+), 19 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index d5bb564f66..60d92f4beb 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -22,6 +22,7 @@ open Evarsolve
 open Globnames
 open Evd
 open Pretype_errors
+open Sigma.Notations
 
 type unify_fun = transparent_state ->
   env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -830,7 +831,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
 	      (i,t2::ks, m-1, test)
 	  else
 	    let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
-            let (i',ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+	    let i = Sigma.Unsafe.of_evar_map i in
+            let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+            let i' = Sigma.to_evar_map i' in
 	    (i', ev :: ks, m - 1,test))
 	(evd,[],List.length bs,fun i -> Success i) bs
     in
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 1c3ae9ad95..bc9f083315 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -385,7 +385,7 @@ let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?prin
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
   let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
   let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
   let instance =
@@ -394,9 +394,14 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
     | Some filter -> Filter.filter_list filter instance in
   new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
 
+let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let evd = Sigma.to_evar_map evd in
+  let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  Sigma.Unsafe.of_pair (c, sigma)
+
 let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
   let evd', s = new_sort_variable rigid evd in
-  let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
+  let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in
     evd', (e, s)
 
 let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
@@ -414,7 +419,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
 
   (* The same using side-effect *)
 let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
-  let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
+  let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
   evdref := evd';
   ev
 
@@ -717,7 +722,7 @@ let define_pure_evar_as_product evd evk =
     let filter = Filter.extend 1 (evar_filter evi) in
       if is_prop_sort s then
        (* Impredicative product, conclusion must fall in [Prop]. *)
-        new_evar newenv evd1 concl ~src ~filter
+        new_evar_unsafe newenv evd1 concl ~src ~filter
       else
 	let evd3, (rng, srng) =
 	  new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in
@@ -763,7 +768,7 @@ let define_pure_evar_as_lambda env evd evk =
   let newenv = push_named (id, None, dom) evenv in
   let filter = Filter.extend 1 (evar_filter evi) in
   let src = evar_source evk evd1 in
-  let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+  let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
   let lam = mkLambda (Name id, dom, subst_var id body) in
   Evd.define evk lam evd2, lam
 
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 76d67c748d..96648bb111 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -22,10 +22,10 @@ val mk_new_meta : unit -> constr
 
 (** {6 Creating a fresh evar given their type and context} *)
 val new_evar :
-  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
   ?candidates:constr list -> ?store:Store.t ->
   ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool -> types -> evar_map * constr
+  ?principal:bool -> types -> (constr, 'r) Sigma.sigma
 
 val new_pure_evar :
   named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 123f9b8cd3..9caa868958 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -27,6 +27,7 @@ open Recordops
 open Locus
 open Locusops
 open Find_subterm
+open Sigma.Notations
 
 let keyed_unification = ref (false)
 let _ = Goptions.declare_bool_option {
@@ -105,7 +106,9 @@ let set_occurrences_of_last_arg args =
   Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
 
 let abstract_list_all_with_dependencies env evd typ c l =
-  let evd,ev = new_evar env evd typ in
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (ev, evd, _) = new_evar env evd typ in
+  let evd = Sigma.to_evar_map evd in
   let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
   let n = List.length l in
   let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -1155,20 +1158,20 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
  * close it off.  But this might not always work,
  * since other metavars might also need to be resolved. *)
 
-let applyHead env evd n c  =
-  let rec apprec n c cty evd =
+let applyHead env (type r) (evd : r Sigma.t) n c =
+  let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
+    fun n c cty p evd ->
     if Int.equal n 0 then
-      (evd, c)
+      Sigma (c, evd, p)
     else
-      match kind_of_term (whd_betadeltaiota env evd cty) with
+      match kind_of_term (whd_betadeltaiota env (Sigma.to_evar_map evd) cty) with
       | Prod (_,c1,c2) ->
-        let (evd',evar) =
-	  Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
-	  apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+        let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+	  apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
       | _ -> error "Apply_Head_Then"
   in
-    apprec n c (Typing.unsafe_type_of env evd c) evd
-    
+    apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+
 let is_mimick_head ts f =
   match kind_of_term f with
   | Const (c,u) -> not (Closure.is_transparent_constant ts c)
@@ -1328,7 +1331,9 @@ let w_merge env with_types flags (evd,metas,evars) =
   and mimick_undefined_evar evd flags hdc nargs sp =
     let ev = Evd.find_undefined evd sp in
     let sp_env = Global.env_of_context ev.evar_hyps in
-    let (evd', c) = applyHead sp_env evd nargs hdc in
+    let evd = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
+    let evd' = Sigma.to_evar_map evd' in
     let (evd'',mc,ec) =
       unify_0 sp_env evd' CUMUL flags
         (get_type_of sp_env evd' c) ev.evar_concl in
-- 
cgit v1.2.3


From c8986ad5589ad5bbed0936f9c16bba3f2ae1d2c4 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 19 Oct 2015 15:46:34 +0200
Subject: More monotonicity in Tactics.

---
 pretyping/unification.ml  | 14 ++++++++++----
 pretyping/unification.mli | 10 +++++-----
 2 files changed, 15 insertions(+), 9 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 9caa868958..269c723e30 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1442,9 +1442,10 @@ let indirect_dependency d decls =
   pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
 
 let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+  let current_sigma = Sigma.to_evar_map current_sigma in
   let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
   let sigma, subst = nf_univ_variables sigma in
-  sigma, subst_univs_constr subst (nf_evar sigma c)
+  Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma)
 
 let default_matching_core_flags sigma =
   let ts = Names.full_transparent_state in {
@@ -1595,7 +1596,11 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
     in
     let lastlhyp =
       if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
-    (id,sign,depdecls,lastlhyp,ccl,out test)
+    let res = match out test with
+    | None -> None
+    | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+    in
+    (id,sign,depdecls,lastlhyp,ccl,res)
   with
     SubtermUnificationError e ->
       raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
@@ -1617,12 +1622,13 @@ type abstraction_request =
 | AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
 | AbstractExact of Name.t * constr * types option * clause * bool
 
-type abstraction_result =
+type 'r abstraction_result =
   Names.Id.t * named_context_val *
     Context.named_declaration list * Names.Id.t option *
-    types * (Evd.evar_map * constr) option
+    types * (constr, 'r) Sigma.sigma option
 
 let make_abstraction env evd ccl abs =
+  let evd = Sigma.to_evar_map evd in
   match abs with
   | AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
       make_abstraction_core name
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 119b1a7590..51a51f3752 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -73,15 +73,15 @@ type abstraction_request =
 | AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
 
 val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
-  env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr
+  env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma
 
-type abstraction_result =
+type 'r abstraction_result =
   Names.Id.t * named_context_val *
     Context.named_declaration list * Names.Id.t option *
-    types * (Evd.evar_map * constr) option
+    types * (constr, 'r) Sigma.sigma option
 
-val make_abstraction : env -> Evd.evar_map -> constr ->
-  abstraction_request -> abstraction_result
+val make_abstraction : env -> 'r Sigma.t -> constr ->
+  abstraction_request -> 'r abstraction_result
 
 val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
 
-- 
cgit v1.2.3


From 7d6d9c5aea6232200b99e828b7e04b49808f8478 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 19 Oct 2015 18:13:32 +0200
Subject: Do occur-check w.r.t existential's types also when instantiating an
 evar.

---
 pretyping/evarsolve.ml | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index bbc4f1db29..b384bdfe16 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1272,6 +1272,15 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs =
           restrict_evar evd evk None (UpdateWith candidates)
       | l -> evd
 
+let occur_evar_upto_types sigma n c =
+  let rec occur_rec c = match kind_of_term c with
+    | Evar (sp,_) when Evar.equal sp n -> raise Occur
+    | Evar e -> Option.iter occur_rec (existential_opt_value sigma e);
+		occur_rec (existential_type sigma e)
+    | _ -> iter_constr occur_rec c
+  in
+  try occur_rec c; false with Occur -> true
+
 (* We try to instantiate the evar assuming the body won't depend
  * on arguments that are not Rels or Vars, or appearing several times
  * (i.e. we tackle a generalization of Miller-Pfenning patterns unification)
@@ -1459,7 +1468,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
 	  (recheck_applications conv_algo (evar_env evi) evdref t'; t')
 	else t'
   in (!evdref,body)
-
+     
 (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
  * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
  * [define] tries to find an instance lhs such that
@@ -1484,7 +1493,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
     if occur_meta body then raise MetaOccurInBodyInternal;
     (* invert_definition may have instantiate some evars of rhs with evk *)
     (* so we recheck acyclicity *)
-    if occur_evar_upto evd' evk body then raise (OccurCheckIn (evd',body));
+    if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body));
     (* needed only if an inferred type *)
     let evd', body = refresh_universes pbty env evd' body in
 (* Cannot strictly type instantiations since the unification algorithm
-- 
cgit v1.2.3


From a1b828d31c73d3342345243e9fb4af69610616a0 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 20 Oct 2015 18:15:04 +0200
Subject: Fix lemma-overloading

Update the evar_source of the solution evar in evar/evar problems to
propagate the information that it does not necessarily have to be solved
in Program mode.
---
 pretyping/evarsolve.ml | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index b384bdfe16..f06207c3b9 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1149,10 +1149,19 @@ let check_evar_instance evd evk1 body conv_algo =
   | Success evd -> evd
   | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl))
 
+let update_evar_source ev1 ev2 evd =
+  let loc, evs2 = evar_source ev2 evd in
+  match evs2 with
+  | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) ->
+     let evi = Evd.find evd ev1 in
+     Evd.add evd ev1 {evi with evar_source = loc, evs2}
+  | _ -> evd
+  
 let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) =
   try
     let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in
     let evd' = Evd.define evk2 body evd in
+    let evd' = update_evar_source (fst (destEvar body)) evk2 evd' in
       check_evar_instance evd' evk2 body g
   with EvarSolvedOnTheFly (evd,c) ->
     f env evd pbty ev2 c
@@ -1164,8 +1173,8 @@ let preferred_orientation evd evk1 evk2 =
   let _,src2 = (Evd.find_undefined evd evk2).evar_source in
   (* This is a heuristic useful for program to work *)
   match src1,src2 with
-  | Evar_kinds.QuestionMark _, _ -> true
-  | _,Evar_kinds.QuestionMark _ -> false
+  | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) , _ -> true
+  | _, (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) -> false
   | _ -> true
 
 let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) =
-- 
cgit v1.2.3


From d1114c5f55fcb96a99a1a5562b014414ad8217ba Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 24 Oct 2015 18:10:24 +0200
Subject: Documenting a bit more interpretation functions in passing.

---
 pretyping/pretyping.mli | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index a6aa086579..5f0e19cf2b 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -66,9 +66,12 @@ val all_and_fail_flags : inference_flags
 (** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
 val allow_anonymous_refs : bool ref
   
-(** Generic call to the interpreter from glob_constr to open_constr, leaving
-    unresolved holes as evars and returning the typing contexts of
-    these evars. Work as [understand_gen] for the rest. *)
+(** Generic calls to the interpreter from glob_constr to open_constr;
+    by default, inference_flags tell to use type classes and
+    heuristics (but no external tactic solver hooks), as well as to
+    ensure that conversion problems are all solved and expand evars,
+    but unresolved evars can remain. The difference is in whether the
+    evar_map is modified explicitly or by side-effect. *)
 
 val understand_tcc : ?flags:inference_flags -> env -> evar_map ->
   ?expected_type:typing_constraint -> glob_constr -> open_constr
@@ -92,7 +95,12 @@ val understand_ltac : inference_flags ->
   env -> evar_map -> ltac_var_map ->
   typing_constraint -> glob_constr -> pure_open_constr
 
-(** Standard call to get a constr from a glob_constr, resolving implicit args *)
+(** Standard call to get a constr from a glob_constr, resolving
+    implicit arguments and coercions, and compiling pattern-matching;
+    the default inference_flags tells to use type classes and
+    heuristics (but no external tactic solver hook), as well as to
+    ensure that conversion problems are all solved and that no
+    unresolved evar remains, expanding evars. *)
 
 val understand : ?flags:inference_flags -> ?expected_type:typing_constraint ->
   env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context
@@ -102,12 +110,13 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint ->
 val understand_judgment : env -> evar_map -> 
   glob_constr -> unsafe_judgment Evd.in_evar_universe_context
 
-(** Idem but do not fail on unresolved evars *)
+(** Idem but do not fail on unresolved evars (type cl*)
 val understand_judgment_tcc : env -> evar_map ref ->
   glob_constr -> unsafe_judgment
 
 (** Trying to solve remaining evars and remaining conversion problems
-    with type classes, heuristics, and possibly an external solver *)
+    possibly using type classes, heuristics, external tactic solver
+    hook depending on given flags. *)
 (* For simplicity, it is assumed that current map has no other evars
    with candidate and no other conversion problems that the one in
    [pending], however, it can contain more evars than the pending ones. *)
@@ -115,7 +124,8 @@ val understand_judgment_tcc : env -> evar_map ref ->
 val solve_remaining_evars : inference_flags ->
   env -> (* initial map *) evar_map -> (* map to solve *) pending -> evar_map
 
-(** Checking evars are all solved and reporting an appropriate error message *)
+(** Checking evars and pending conversion problems are all solved,
+    reporting an appropriate error message *)
 
 val check_evars_are_solved :
   env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
-- 
cgit v1.2.3


From e3ec13976d39909ac6f1a82bf1b243ba8a895190 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Wed, 28 Oct 2015 12:42:27 +0100
Subject: Revert "Fixing #4198 (continued): not matching within the inner
 lambdas/let-ins"

After all, let's target 8.6.
---
 pretyping/constr_matching.ml | 19 +++----------------
 1 file changed, 3 insertions(+), 16 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 3fa037ffdd..5e99521a12 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -413,25 +413,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
             mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
           let sub = (env, c1) :: subargs env lc in
           try_aux sub mk_ctx next
-  | Case (ci,p,c,brs) ->
-      (* Warning: this assumes predicate and branches to be
-         in canonical form using let and fun of the signature *)
-      let nardecls = List.length ci.ci_pp_info.ind_tags in
-      let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in
-      let env_p = Environ.push_rel_context sign_p env in
-      let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in
-      let sign_brs = Array.map fst brs in
-      let f (sign,br) = (Environ.push_rel_context sign env, br) in
-      let sub_br = Array.map f brs in
+  | Case (ci,hd,c1,lc) ->
       let next_mk_ctx = function
-      | c :: p :: brs ->
-        let p = it_mkLambda_or_LetIn p sign_p in
-        let brs =
-          Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in
-        mk_ctx (mkCase (ci,p,c,brs))
+      | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
       | _ -> assert false
       in
-      let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in
+      let sub = (env, c1) :: (env, hd) :: subargs env lc in
       try_aux sub next_mk_ctx next
   | Fix (indx,(names,types,bodies)) ->
     let nb_fix = Array.length types in
-- 
cgit v1.2.3


From 7d9331a2a188842a98936278d02177f1a6fa7001 Mon Sep 17 00:00:00 2001
From: Gregory Malecha
Date: Sat, 17 Oct 2015 21:40:49 -0700
Subject: Adds support for the virtual machine to perform reduction of universe
 polymorphic definitions.

- This implementation passes universes in separate arguments and does not
  eagerly instanitate polymorphic definitions.
- This means that it pays no cost on monomorphic definitions.
---
 pretyping/vnorm.ml | 96 ++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 72 insertions(+), 24 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 46af784dda..b9c1a5a1c7 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -93,19 +93,6 @@ let construct_of_constr_const env tag typ =
 
 let construct_of_constr_block = construct_of_constr false
 
-let constr_type_of_idkey env idkey =
-  match idkey with
-  | ConstKey cst ->
-    let const_type = Typeops.type_of_constant_in env cst in
-      mkConstU cst, const_type
-  | VarKey id ->
-      let (_,_,ty) = lookup_named id env in
-      mkVar id, ty
-  | RelKey i ->
-      let n = (nb_rel env - i) in
-      let (_,_,ty) = lookup_rel n env in
-      mkRel n, lift n ty
-
 let type_of_ind env (ind, u) =
   type_of_inductive env (Inductive.lookup_mind_specif env ind, u)
 
@@ -164,9 +151,11 @@ and nf_whd env whd typ =
       let t = ta.(i) in
       let _, args = nf_args env vargs t in
       mkApp(cfd,args)
-  | Vconstr_const n -> construct_of_constr_const env n typ
+  | Vconstr_const n ->
+    construct_of_constr_const env n typ
   | Vconstr_block b ->
       let tag = btag b in
+      let x = tag in
       let (tag,ofs) =
         if tag = Cbytecodes.last_variant_tag then
 	  match whd_val (bfield b 0) with
@@ -177,22 +166,80 @@ and nf_whd env whd typ =
       let args = nf_bargs env b ofs ctyp in
       mkApp(capp,args)
   | Vatom_stk(Aid idkey, stk) ->
-      let c,typ = constr_type_of_idkey env idkey in
-      nf_stk env c typ stk
-  | Vatom_stk(Aind ind, stk) ->
-      nf_stk env (mkIndU ind) (type_of_ind env ind) stk
+      constr_type_of_idkey env idkey stk nf_stk
+(*let c,typ = constr_type_of_idkey env idkey in
+      nf_stk env c typ stk *)
+  | Vatom_stk(Aind ((mi,i) as ind), stk) ->
+      if Environ.polymorphic_ind ind env then
+	let mib = Environ.lookup_mind mi env in
+	let ulen = Univ.UContext.size mib.mind_universes in
+	match stk with
+	| Zapp args :: stk' ->
+	  assert (ulen <= nargs args) ;
+	  let inst =
+	    Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i))
+	  in
+	  let pind = (ind, Univ.Instance.of_array inst) in
+	  nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk
+	| _ -> assert false
+      else
+	let pind = (ind, Univ.Instance.empty) in
+	nf_stk env (mkIndU pind) (type_of_ind env pind) stk
+  | Vatom_stk(Atype u, stk) ->
+    mkSort (Type (Vm.instantiate_universe u stk))
+  | Vuniv_level lvl ->
+    assert false
+
+and constr_type_of_idkey env (idkey : Vars.id_key) stk cont =
+  match idkey with
+  | ConstKey cst ->
+    if Environ.polymorphic_constant cst env then
+      let cbody = Environ.lookup_constant cst env in
+      match stk with
+      | Zapp vargs :: stk' ->
+        let uargs = Univ.UContext.size cbody.const_universes in
+        assert (Vm.nargs vargs >= uargs) ;
+        let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in
+        let ui = Univ.Instance.of_array uary in
+	let ucst = (cst, ui) in
+	let const_type = Typeops.type_of_constant_in env ucst in
+        if uargs < Vm.nargs vargs then
+	  let t, args = nf_args env vargs ~from:uargs const_type in
+          cont env (mkApp (mkConstU ucst, args)) t stk'
+        else
+          cont env (mkConstU ucst) const_type stk'
+      | _ -> assert false
+    else
+      begin
+	let ucst = (cst, Univ.Instance.empty) in
+	let const_type = Typeops.type_of_constant_in env ucst in
+        cont env (mkConstU ucst) const_type stk
+      end
+  | VarKey id ->
+      let (_,_,ty) = lookup_named id env in
+      cont env (mkVar id) ty stk
+  | RelKey i ->
+      let n = (nb_rel env - i) in
+      let (_,_,ty) = lookup_rel n env in
+      cont env (mkRel n) (lift n ty) stk
 
-and nf_stk env c t stk  =
+and nf_stk ?from:(from=0) env c t stk  =
   match stk with
   | [] -> c
   | Zapp vargs :: stk ->
-      let t, args = nf_args env vargs t in
-      nf_stk env (mkApp(c,args)) t stk
+      if nargs vargs >= from then
+	let t, args = nf_args ~from:from env vargs t in
+	nf_stk env (mkApp(c,args)) t stk
+      else
+	let rest = from - nargs vargs in
+	nf_stk ~from:rest env c t stk
   | Zfix (f,vargs) :: stk ->
+      assert (from = 0) ;
       let fa, typ = nf_fix_app env f vargs in
       let _,_,codom = decompose_prod env typ in
       nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk
   | Zswitch sw :: stk ->
+      assert (from = 0) ;
       let ((mind,_ as ind), u), allargs = find_rectype_a env t in
       let (mib,mip) = Inductive.lookup_mind_specif env ind in
       let nparams = mib.mind_nparams in
@@ -215,6 +262,7 @@ and nf_stk env c t stk  =
       let ci = case_info sw in
       nf_stk env (mkCase(ci, p, c, branchs)) tcase stk
   | Zproj p :: stk ->
+     assert (from = 0) ;
      let p' = Projection.make p true in
      let ty = Inductiveops.type_of_projection_knowing_arg env Evd.empty p' c t in
      nf_stk env (mkProj(p',c)) ty stk
@@ -240,14 +288,14 @@ and nf_predicate env ind mip params v pT =
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type
 
-and nf_args env vargs t =
+and nf_args env vargs ?from:(f=0) t =
   let t = ref t in
-  let len = nargs vargs in
+  let len = nargs vargs - f in
   let args =
     Array.init len
       (fun i ->
 	let _,dom,codom = decompose_prod env !t in
-	let c = nf_val env (arg vargs i) dom in
+	let c = nf_val env (arg vargs (f+i)) dom in
 	t := subst1 c codom; c) in
   !t,args
 
-- 
cgit v1.2.3


From 90dfacaacfec8265b11dc9291de9510f515c0081 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Tue, 27 Oct 2015 23:59:05 +0100
Subject: Conversion of polymorphic inductive types was incomplete in VM and
 native.

Was showing up when comparing e.g. prod Type Type with prod Type Type (!) with
a polymorphic prod.
---
 pretyping/reductionops.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index bb1bc7d2ea..0714c93b4f 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1282,7 +1282,7 @@ let sigma_compare_sorts env pb s0 s1 sigma =
   | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1
   | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1
     
-let sigma_compare_instances flex i0 i1 sigma =
+let sigma_compare_instances ~flex i0 i1 sigma =
   try Evd.set_eq_instances ~flex sigma i0 i1
   with Evd.UniversesDiffer
      | Univ.UniverseInconsistency _ ->
-- 
cgit v1.2.3


From 4f8a9d10123bd8aa4d17853a7248d3b3fe8a3625 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Wed, 28 Oct 2015 11:16:24 +0100
Subject: Refine Gregory Malecha's patch on VM and universe polymorphism.

- Universes are now represented in the VM by a structured constant containing the
  global levels. This constant is applied to local level variables if any.
- When reading back a universe, we perform the union of these levels and return
  a [Vsort].
- Fixed a bug: structured constants could contain local universe variables in
  constructor arguments, which has to be prevented.
  Was showing up for instance when evaluating [cons _ list (nil _)] with
  a polymorphic [list] type.
- Fixed a bug: polymorphic inductive types can have an empty stack.
  Was showing up when evaluating [bool] with a polymorphic [bool] type.
- Made a few cosmetic changes.

Patch written with Benjamin Grégoire.
---
 pretyping/vnorm.ml | 85 ++++++++++++++++++++++++------------------------------
 1 file changed, 38 insertions(+), 47 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index b9c1a5a1c7..c4c85a62ed 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -155,7 +155,6 @@ and nf_whd env whd typ =
     construct_of_constr_const env n typ
   | Vconstr_block b ->
       let tag = btag b in
-      let x = tag in
       let (tag,ofs) =
         if tag = Cbytecodes.last_variant_tag then
 	  match whd_val (bfield b 0) with
@@ -166,62 +165,54 @@ and nf_whd env whd typ =
       let args = nf_bargs env b ofs ctyp in
       mkApp(capp,args)
   | Vatom_stk(Aid idkey, stk) ->
-      constr_type_of_idkey env idkey stk nf_stk
-(*let c,typ = constr_type_of_idkey env idkey in
-      nf_stk env c typ stk *)
+      constr_type_of_idkey env idkey stk
   | Vatom_stk(Aind ((mi,i) as ind), stk) ->
-      if Environ.polymorphic_ind ind env then
-	let mib = Environ.lookup_mind mi env in
-	let ulen = Univ.UContext.size mib.mind_universes in
-	match stk with
-	| Zapp args :: stk' ->
-	  assert (ulen <= nargs args) ;
-	  let inst =
-	    Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i))
-	  in
-	  let pind = (ind, Univ.Instance.of_array inst) in
-	  nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk
-	| _ -> assert false
-      else
-	let pind = (ind, Univ.Instance.empty) in
-	nf_stk env (mkIndU pind) (type_of_ind env pind) stk
-  | Vatom_stk(Atype u, stk) ->
-    mkSort (Type (Vm.instantiate_universe u stk))
+     let mib = Environ.lookup_mind mi env in
+     let nb_univs =
+       if mib.mind_polymorphic then Univ.UContext.size mib.mind_universes
+       else 0
+     in
+     let mk u =
+       let pind = (ind, u) in (mkIndU pind, type_of_ind env pind)
+     in
+     nf_univ_args ~nb_univs mk env stk
+  | Vatom_stk(Atype u, stk) -> assert false
   | Vuniv_level lvl ->
     assert false
 
-and constr_type_of_idkey env (idkey : Vars.id_key) stk cont =
+and nf_univ_args ~nb_univs mk env stk =
+  let u =
+    if Int.equal nb_univs 0 then Univ.Instance.empty
+    else match stk with
+    | Zapp args :: _ ->
+       let inst =
+	 Array.init nb_univs (fun i -> Vm.uni_lvl_val (arg args i))
+       in
+       Univ.Instance.of_array inst
+    | _ -> assert false
+  in
+  let (t,ty) = mk u in
+  nf_stk ~from:nb_univs env t ty stk
+
+and constr_type_of_idkey env (idkey : Vars.id_key) stk =
   match idkey with
   | ConstKey cst ->
-    if Environ.polymorphic_constant cst env then
-      let cbody = Environ.lookup_constant cst env in
-      match stk with
-      | Zapp vargs :: stk' ->
-        let uargs = Univ.UContext.size cbody.const_universes in
-        assert (Vm.nargs vargs >= uargs) ;
-        let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in
-        let ui = Univ.Instance.of_array uary in
-	let ucst = (cst, ui) in
-	let const_type = Typeops.type_of_constant_in env ucst in
-        if uargs < Vm.nargs vargs then
-	  let t, args = nf_args env vargs ~from:uargs const_type in
-          cont env (mkApp (mkConstU ucst, args)) t stk'
-        else
-          cont env (mkConstU ucst) const_type stk'
-      | _ -> assert false
-    else
-      begin
-	let ucst = (cst, Univ.Instance.empty) in
-	let const_type = Typeops.type_of_constant_in env ucst in
-        cont env (mkConstU ucst) const_type stk
-      end
-  | VarKey id ->
+     let cbody = Environ.lookup_constant cst env in
+     let nb_univs =
+       if cbody.const_polymorphic then Univ.UContext.size cbody.const_universes
+       else 0
+     in
+     let mk u =
+       let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst)
+     in
+     nf_univ_args ~nb_univs mk env stk
+   | VarKey id ->
       let (_,_,ty) = lookup_named id env in
-      cont env (mkVar id) ty stk
+      nf_stk env (mkVar id) ty stk
   | RelKey i ->
       let n = (nb_rel env - i) in
       let (_,_,ty) = lookup_rel n env in
-      cont env (mkRel n) (lift n ty) stk
+      nf_stk env (mkRel n) (lift n ty) stk
 
 and nf_stk ?from:(from=0) env c t stk  =
   match stk with
-- 
cgit v1.2.3


From f1dd27ae0e6082b111770fa74cba6abda30f3b89 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Wed, 28 Oct 2015 12:51:51 +0100
Subject: Fix bug in native compiler with universe polymorphism.

Universe instances for constructors were not always correct, for instance in:
[cons _ list (nil _)] with a polymorphic [list] type, [nil] was receiving an
empty instance.
---
 pretyping/nativenorm.ml | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index dafe88d8db..de988aa2cd 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -53,8 +53,8 @@ let find_rectype_a env c =
 
 (* Instantiate inductives and parameters in constructor type *)
 
-let type_constructor mind mib typ params = 
-  let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in
+let type_constructor mind mib u typ params =
+  let s = ind_subst mind mib u in
   let ctyp = substl s typ in
   let nparams = Array.length params in
   if Int.equal nparams 0 then ctyp
@@ -68,13 +68,13 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs =
   let params = Array.sub allargs 0 nparams in
   try
     if const then
-      let ctyp = type_constructor mind mib (mip.mind_nf_lc.(0)) params in
+      let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in
       retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag, ctyp
     else
       raise Not_found
   with Not_found ->
   let i = invert_tag const tag mip.mind_reloc_tbl in
-  let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
+  let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in
   (mkApp(mkConstructU((ind,i),u), params), ctyp)
  
 
@@ -90,12 +90,12 @@ let construct_of_constr_const env tag typ =
 
 let construct_of_constr_block = construct_of_constr false
 
-let build_branches_type env (mind,_ as _ind) mib mip params dep p =
+let build_branches_type env (mind,_ as _ind) mib mip u params dep p =
   let rtbl = mip.mind_reloc_tbl in
   (* [build_one_branch i cty] construit le type de la ieme branche (commence
      a 0) et les lambda correspondant aux realargs *)
   let build_one_branch i cty =
-    let typi = type_constructor mind mib cty params in
+    let typi = type_constructor mind mib u cty params in
     let decl,indapp = Reductionops.splay_prod env Evd.empty typi in
     let decl_with_letin,_ = decompose_prod_assum typi in
     let ind,cargs = find_rectype_a env indapp in
@@ -292,7 +292,7 @@ and nf_atom_type env atom =
       let pT = whd_betadeltaiota env pT in
       let dep, p = nf_predicate env ind mip params p pT in
       (* Calcul du type des branches *)
-      let btypes = build_branches_type env (fst ind) mib mip params dep p in
+      let btypes = build_branches_type env (fst ind) mib mip u params dep p in
       (* calcul des branches *)
       let bsw = branch_of_switch (nb_rel env) ans bs in
       let mkbranch i v =
-- 
cgit v1.2.3


From 908dcd613b12645f3b62bf44c2696b80a0b16940 Mon Sep 17 00:00:00 2001
From: Enrico Tassi
Date: Wed, 28 Oct 2015 16:46:42 +0100
Subject: Avoid type checking private_constants (side_eff) again during Qed
 (#4357).

Side effects are now an opaque data type, called private_constant, you can
only obtain from safe_typing.  When add_constant is called on a
definition_entry that contains private constants, they are either
- inlined in the main proof term but not re-checked
- declared globally without re-checking them
As a safety measure, the opaque data type contains a pointer to the
revstruct (an internal field of safe_env that changes every time a new
constant is added), and such pointer is compared with the current value
store in safe_env when the private_constant is inlined.  Only when the
comparison is successful the private_constant is not re-checked.  Otherwise
else it is.  In short, we accept into the kernel private constant only
when they arrive in the very same order and on top of the very same env
they arrived when we fist checked them.

Note: private_constants produced by workers never pass the safety
measure (the revstruct pointer is an Ephemeron).  Sending back the
entire revstruct is possible but: 1. we lack a way to quickly compare
two revstructs, 2. it can be large.
---
 pretyping/evd.ml  | 26 ++++++--------------------
 pretyping/evd.mli |  4 ++--
 2 files changed, 8 insertions(+), 22 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 1107c2951e..0593bbca8a 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -579,7 +579,7 @@ type evar_map = {
   (** Metas *)
   metas      : clbinding Metamap.t;
   (** Interactive proofs *)
-  effects    : Declareops.side_effects;
+  effects    : Safe_typing.private_constants;
   future_goals : Evar.t list; (** list of newly created evars, to be
                                   eventually turned into goals if not solved.*)
   principal_future_goal : Evar.t option; (** if [Some e], [e] must be
@@ -768,7 +768,7 @@ let empty = {
   conv_pbs   = [];
   last_mods  = Evar.Set.empty;
   metas      = Metamap.empty;
-  effects    = Declareops.no_seff;
+  effects    = Safe_typing.empty_private_constants;
   evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
   future_goals = [];
   principal_future_goal = None;
@@ -1041,22 +1041,8 @@ let with_context_set rigid d (a, ctx) =
   (merge_context_set rigid d ctx, a)
 
 let emit_universe_side_effects eff u =
-  Declareops.fold_side_effects
-    (fun acc eff ->
-     match eff with
-     | Declarations.SEscheme (l,s) ->
-	List.fold_left
-	  (fun acc (_,_,cb,c) ->
-	   let acc = match c with
-	     | `Nothing -> acc
-	     | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx
-	   in if cb.Declarations.const_polymorphic then acc
-	      else
-		merge_uctx true univ_rigid acc
-			   (Univ.ContextSet.of_context cb.Declarations.const_universes))
-	  acc l
-     | Declarations.SEsubproof _ -> acc)
-    u eff
+  let uctxs = Safe_typing.universes_of_private eff in
+  List.fold_left (merge_uctx true univ_rigid) u uctxs
         
 let add_uctx_names s l (names, names_rev) =
     (UNameMap.add s l names, Univ.LMap.add l s names_rev)
@@ -1399,11 +1385,11 @@ let e_eq_constr_univs evdref t u =
 (* Side effects *)
 
 let emit_side_effects eff evd =
-  { evd with effects = Declareops.union_side_effects eff evd.effects;
+  { evd with effects = Safe_typing.concat_private eff evd.effects;
 	     universes = emit_universe_side_effects eff evd.universes }
 
 let drop_side_effects evd =
-  { evd with effects = Declareops.no_seff; }
+  { evd with effects = Safe_typing.empty_private_constants; }
 
 let eval_side_effects evd = evd.effects
 
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 52d7d42120..9379b50b52 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -261,10 +261,10 @@ val dependent_evar_ident : existential_key -> evar_map -> Id.t
 
 (** {5 Side-effects} *)
 
-val emit_side_effects : Declareops.side_effects -> evar_map -> evar_map
+val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map
 (** Push a side-effect into the evar map. *)
 
-val eval_side_effects : evar_map -> Declareops.side_effects
+val eval_side_effects : evar_map -> Safe_typing.private_constants
 (** Return the effects contained in the evar map. *)
 
 val drop_side_effects : evar_map -> evar_map
-- 
cgit v1.2.3


From 0132b5b51fc1856356fb74130d3dea7fd378f76c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 28 Oct 2015 12:36:20 -0400
Subject: Univs: local names handling.

Keep user-side information on the names used in instances of universe
polymorphic references and use them for printing.
---
 pretyping/evd.ml  | 30 ++++++++++++++++++++----------
 pretyping/evd.mli |  6 +++++-
 2 files changed, 25 insertions(+), 11 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 0593bbca8a..36d9c25fdd 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -356,6 +356,16 @@ let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_loca
 let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx }
 let evar_universe_context_subst ctx = ctx.uctx_univ_variables
 
+let add_uctx_names s l (names, names_rev) =
+  (UNameMap.add s l names, Univ.LMap.add l s names_rev)
+
+let evar_universe_context_of_binders b =
+  let ctx = empty_evar_universe_context in
+  let names =
+    List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
+		   ctx.uctx_names b
+  in { ctx with uctx_names = names }
+					
 let instantiate_variable l b v =
   v := Univ.LMap.add l (Some b) !v
 
@@ -965,19 +975,19 @@ let pr_uctx_level uctx =
 
 let universe_context ?names evd =
   match names with
-  | None -> Univ.ContextSet.to_context evd.universes.uctx_local
+  | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local
   | Some pl ->
      let levels = Univ.ContextSet.levels evd.universes.uctx_local in
-     let newinst, left =
+     let newinst, map, left =
        List.fold_right
-         (fun (loc,id) (newinst, acc) ->
+         (fun (loc,id) (newinst, map, acc) ->
 	  let l =
 	    try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
 	    with Not_found ->
 	      user_err_loc (loc, "universe_context",
 			    str"Universe " ++ pr_id id ++ str" is not bound anymore.")
-	  in (l :: newinst, Univ.LSet.remove l acc))
-	 pl ([], levels)
+	  in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
+	 pl ([], [], levels)
      in
        if not (Univ.LSet.is_empty left) then
          let n = Univ.LSet.cardinal left in
@@ -985,8 +995,11 @@ let universe_context ?names evd =
 			(str(CString.plural n "Universe") ++ spc () ++
 			     Univ.LSet.pr (pr_uctx_level evd.universes) left ++
 			     spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
-       else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst),
-				Univ.ContextSet.constraints evd.universes.uctx_local)
+       else
+	 let inst = Univ.Instance.of_array (Array.of_list newinst) in
+	 let ctx = Univ.UContext.make (inst,
+           Univ.ContextSet.constraints evd.universes.uctx_local)
+	 in map, ctx
 
 let restrict_universe_context evd vars =
   let uctx = evd.universes in
@@ -1044,9 +1057,6 @@ let emit_universe_side_effects eff u =
   let uctxs = Safe_typing.universes_of_private eff in
   List.fold_left (merge_uctx true univ_rigid) u uctxs
         
-let add_uctx_names s l (names, names_rev) =
-    (UNameMap.add s l names, Univ.LMap.add l s names_rev)
-
 let uctx_new_univ_variable rigid name predicative
   ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
   let u = Universes.new_univ_level (Global.current_dirpath ()) in
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 9379b50b52..3c16b27ad9 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -487,6 +487,9 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context
   evar_universe_context
 val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
 
+val evar_universe_context_of_binders :
+  Universes.universe_binders -> evar_universe_context
+							    
 val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context
 val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map							   
 (** Raises Not_found if not a name for a universe in this map. *)
@@ -534,7 +537,8 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool
 
 val evar_universe_context : evar_map -> evar_universe_context
 val universe_context_set : evar_map -> Univ.universe_context_set
-val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context
+val universe_context : ?names:(Id.t located) list -> evar_map ->
+		       (Id.t * Univ.Level.t) list * Univ.universe_context
 val universe_subst : evar_map -> Universes.universe_opt_subst
 val universes : evar_map -> Univ.universes
 
-- 
cgit v1.2.3


From f02f64a21863ce03f2da4ff04cd003051f96801f Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Thu, 29 Oct 2015 18:18:43 +0100
Subject: Removing some goal unsafeness in inductive schemes.

---
 pretyping/indrec.ml  | 10 +++++++---
 pretyping/indrec.mli |  8 ++++----
 2 files changed, 11 insertions(+), 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 54d47fbe00..6dfc32bf1a 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -28,6 +28,7 @@ open Inductiveops
 open Environ
 open Reductionops
 open Nametab
+open Sigma.Notations
 
 type dep_flag = bool
 
@@ -120,13 +121,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       mkLambda_string "f" t
 	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
   in
-  let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+  let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
   let typP = make_arity env' dep indf s in
   let c = 
     it_mkLambda_or_LetIn_name env
     (mkLambda_string "P" typP
      (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
-  in sigma, c
+  in
+  Sigma (c, sigma, p)
 
 (* check if the type depends recursively on one of the inductive scheme *)
 
@@ -474,7 +476,9 @@ let mis_make_indrec env sigma listdepkind mib u =
 	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
 	    lnamesparrec
       else
-	let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in
+        let sigma = Sigma.Unsafe.of_evar_map !evdref in
+        let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in
+        let evd' = Sigma.to_evar_map sigma in
 	  evdref := evd'; c
   in
     (* Body of mis_make_indrec *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index f616c96792..81416a322b 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -25,13 +25,13 @@ type dep_flag = bool
 
 (** Build a case analysis elimination scheme in some sort family *)
 
-val build_case_analysis_scheme : env -> evar_map -> pinductive ->
-      dep_flag -> sorts_family -> evar_map * constr
+val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive ->
+      dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma
 
 (** Build a dependent case elimination predicate unless type is in Prop *)
 
-val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
-      sorts_family -> evar_map * constr
+val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive ->
+      sorts_family -> (constr, 'r) Sigma.sigma
 
 (** Builds a recursive induction scheme (Peano-induction style) in the same
    sort family as the inductive family; it is dependent if not in Prop *)
-- 
cgit v1.2.3


From a3a17b514a2ffaba54cd182fdf27b7e84366ab44 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 29 Oct 2015 15:11:29 -0400
Subject: Handle side-effects of Vernacular commands inside proofs better, so
 that universes are declared correctly in the enclosing proofs evar_map's.

---
 pretyping/evd.ml  | 9 +++++++++
 pretyping/evd.mli | 2 ++
 2 files changed, 11 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 36d9c25fdd..db6b366b75 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1358,6 +1358,15 @@ let add_universe_name evd s l =
 
 let universes evd = evd.universes.uctx_universes
 
+let update_sigma_env evd env =
+  let univs = Environ.universes env in
+  let eunivs =
+    { evd.universes with uctx_initial_universes = univs;
+			 uctx_universes = univs }
+  in
+  let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in
+  { evd with universes = eunivs }
+
 (* Conversion w.r.t. an evar map and its local universes. *)
 
 let conversion_gen env evd pb t u =
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 3c16b27ad9..671d62021a 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -560,6 +560,8 @@ val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_sub
 
 val nf_constraints : evar_map -> evar_map
 
+val update_sigma_env : evar_map -> env -> evar_map
+
 (** Polymorphic universes *)
 
 val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts
-- 
cgit v1.2.3


From 739d8e50b3681491bd82b516dbbba892ac5b424b Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 2 Nov 2015 13:48:53 -0500
Subject: Refresh rigid universes as well, and in 8.4 compatibility mode, make
 them rigid to disallow minimization.

---
 pretyping/evarsolve.ml | 18 +++++++++++-------
 pretyping/evarutil.ml  |  6 ++++--
 2 files changed, 15 insertions(+), 9 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index f06207c3b9..3c3720388f 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -42,11 +42,15 @@ let get_polymorphic_positions f =
         templ.template_param_levels)
   | _ -> assert false
 
-(**
-   forall A (l : list A) -> typeof A = Type i <= Datatypes.j -> i not refreshed
-   hd ?A (l : list t) -> A = t
+let default_universe_status u =
+  if Flags.version_less_or_equal Flags.V8_4 then univ_rigid
+  else u
+
+let refresh_level evd s =
+  match Evd.is_sort_variable evd s with
+  | None -> true
+  | Some l -> not (Evd.is_flexible_level evd l)
 
-*)
 let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
   let evdref = ref evd in
   let modified = ref false in
@@ -54,10 +58,10 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
     match kind_of_term t with
     | Sort (Type u as s) when
       (match Univ.universe_level u with
-      | None -> true 
-      | Some l -> not onlyalg && Option.is_empty (Evd.is_sort_variable evd s)) ->
+      | None -> true
+      | Some l -> not onlyalg && refresh_level evd s) ->
     let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in
-    let s' = evd_comb0 (new_sort_variable status) evdref in
+    let s' = evd_comb0 (new_sort_variable (default_universe_status status)) evdref in
     let evd = 
       if dir then set_leq_sort env !evdref s' s
       else set_leq_sort env !evdref s s'
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index d3d6901b66..b27803bd05 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -715,7 +715,8 @@ let define_pure_evar_as_product evd evk =
   let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
   let concl = whd_betadeltaiota evenv evd evi.evar_concl in
   let s = destSort concl in
-  let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+  let evd1,(dom,u1) =
+    new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
   let evd2,rng =
     let newenv = push_named (id, None, dom) evenv in
     let src = evar_source evk evd1 in
@@ -724,8 +725,9 @@ let define_pure_evar_as_product evd evk =
        (* Impredicative product, conclusion must fall in [Prop]. *)
         new_evar newenv evd1 concl ~src ~filter
       else
+	let status = univ_flexible_alg in
 	let evd3, (rng, srng) =
-	  new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in
+	  new_type_evar newenv evd1 status ~src ~filter in
 	let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
 	let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
 	  evd3, rng
-- 
cgit v1.2.3


From c920b420a27bd561967e316dcaca41d5e019a7b8 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 2 Nov 2015 14:41:17 -0500
Subject: Fix bug #4151: discrepancy between exact and eexact/eassumption.

---
 pretyping/evd.ml  | 10 ++--------
 pretyping/evd.mli |  9 +++------
 2 files changed, 5 insertions(+), 14 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index db6b366b75..82c068be07 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1369,7 +1369,7 @@ let update_sigma_env evd env =
 
 (* Conversion w.r.t. an evar map and its local universes. *)
 
-let conversion_gen env evd pb t u =
+let test_conversion_gen env evd pb t u =
   match pb with 
   | Reduction.CONV -> 
     Reduction.trans_conv_universes 
@@ -1379,14 +1379,8 @@ let conversion_gen env evd pb t u =
      full_transparent_state ~evars:(existential_opt_value evd) env 
     evd.universes.uctx_universes t u
 
-(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *)
-(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *)
-
-let conversion env d pb t u =
-  conversion_gen env d pb t u; d
-
 let test_conversion env d pb t u =
-  try conversion_gen env d pb t u; true
+  try test_conversion_gen env d pb t u; true
   with _ -> false
 
 let eq_constr_univs evd t u =
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 671d62021a..5c508419a4 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -573,14 +573,11 @@ val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map ->
   Globnames.global_reference -> evar_map * constr
 
 (********************************************************************
-  Conversion w.r.t. an evar map: might generate universe unifications 
-  that are kept in the evarmap.
-  Raises [NotConvertible]. *)
-
-val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map
+  Conversion w.r.t. an evar map, not unifying universes. See 
+  [Reductionops.infer_conv] for conversion up-to universes. *)
 
 val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool
-(** This one forgets about the assignemts of universes. *)
+(** WARNING: This does not allow unification of universes *)
 
 val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool
 (** Syntactic equality up to universes, recording the associated constraints *)
-- 
cgit v1.2.3


From 95a4fcf8cd36e29034e886682ed3a6e2914ce04f Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 4 Nov 2015 12:52:35 -0500
Subject: Univs: compatibility with 8.4.

When refreshing a type variable, always use a rigid universe to force the most
general universe constraint, as in 8.4.
---
 pretyping/evarsolve.ml | 7 +------
 1 file changed, 1 insertion(+), 6 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 3c3720388f..ee666e1154 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -42,10 +42,6 @@ let get_polymorphic_positions f =
         templ.template_param_levels)
   | _ -> assert false
 
-let default_universe_status u =
-  if Flags.version_less_or_equal Flags.V8_4 then univ_rigid
-  else u
-
 let refresh_level evd s =
   match Evd.is_sort_variable evd s with
   | None -> true
@@ -60,8 +56,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
       (match Univ.universe_level u with
       | None -> true
       | Some l -> not onlyalg && refresh_level evd s) ->
-    let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in
-    let s' = evd_comb0 (new_sort_variable (default_universe_status status)) evdref in
+    let s' = evd_comb0 (new_sort_variable univ_rigid) evdref in
     let evd = 
       if dir then set_leq_sort env !evdref s' s
       else set_leq_sort env !evdref s s'
-- 
cgit v1.2.3


From 209faf81c432c39d4537f8b1dc5c9947d4349d30 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 4 Nov 2015 14:35:02 -0500
Subject: Univs: update refman, better printers for universe contexts.

---
 pretyping/evd.ml       | 5 ++---
 pretyping/pretyping.ml | 2 +-
 2 files changed, 3 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 82c068be07..4a9466f4f3 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -280,9 +280,8 @@ type evar_universe_context =
    uctx_univ_variables : Universes.universe_opt_subst;
    (** The local universes that are unification variables *)
    uctx_univ_algebraic : Univ.universe_set; 
-   (** The subset of unification variables that
-	can be instantiated with algebraic universes as they appear in types 
-	and universe instances only. *)
+   (** The subset of unification variables that can be instantiated with
+	algebraic universes as they appear in inferred types only. *)
    uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
    uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
  }
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index d484df69c1..d354a6c3c4 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -118,7 +118,7 @@ let _ =
 	  { optsync  = true;
             optdepr  = false;
 	    optname  = "minimization to Set";
-	    optkey   = ["Universe";"set";"Minimization"];
+	    optkey   = ["Universe";"Minimization";"ToSet"];
 	    optread  = Universes.is_set_minimization;
 	    optwrite = (:=) Universes.set_minimization })
 						  
-- 
cgit v1.2.3


From 7c102bb3a3798a234701fdc28a8e8ec28ee2549c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 4 Nov 2015 18:09:02 -0500
Subject: Univs: missing checks in evarsolve with candidates and missing a
 whd_evar in refresh_universes.

---
 pretyping/evarsolve.ml | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index ee666e1154..35bc1de593 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -50,24 +50,24 @@ let refresh_level evd s =
 let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
   let evdref = ref evd in
   let modified = ref false in
-  let rec refresh dir t = 
+  let rec refresh status dir t = 
     match kind_of_term t with
     | Sort (Type u as s) when
       (match Univ.universe_level u with
       | None -> true
       | Some l -> not onlyalg && refresh_level evd s) ->
-    let s' = evd_comb0 (new_sort_variable univ_rigid) evdref in
+    let s' = evd_comb0 (new_sort_variable status) evdref in
     let evd = 
       if dir then set_leq_sort env !evdref s' s
       else set_leq_sort env !evdref s s'
     in
       modified := true; evdref := evd; mkSort s'
     | Prod (na,u,v) -> 
-      mkProd (na,u,refresh dir v)
+      mkProd (na,u,refresh status dir v)
     | _ -> t
   (** Refresh the types of evars under template polymorphic references *)
   and refresh_term_evars onevars top t =
-    match kind_of_term t with
+    match kind_of_term (whd_evar !evdref t) with
     | App (f, args) when is_template_polymorphic env f ->
       let pos = get_polymorphic_positions f in
 	refresh_polymorphic_positions args pos
@@ -76,7 +76,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
       Array.iter (refresh_term_evars onevars false) args
     | Evar (ev, a) when onevars ->
       let evi = Evd.find !evdref ev in
-      let ty' = refresh true evi.evar_concl in
+      let ty' = refresh univ_flexible true evi.evar_concl in
 	if !modified then 
 	  evdref := Evd.add !evdref ev {evi with evar_concl = ty'}
 	else ()
@@ -98,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
     if isArity t then
       (match pbty with
       | None -> t
-      | Some dir -> refresh dir t)
+      | Some dir -> refresh univ_rigid dir t)
     else (refresh_term_evars false true t; t)
   in
     if !modified then !evdref, t' else !evdref, t
@@ -1274,7 +1274,10 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs =
       | [c,evd] ->
           (* solve_candidates might have been called recursively in the mean *)
           (* time and the evar been solved by the filtering process *)
-          if Evd.is_undefined evd evk then Evd.define evk c evd else evd
+         if Evd.is_undefined evd evk then
+	   let evd' = Evd.define evk c evd in
+	     check_evar_instance evd' evk c conv_algo
+	 else evd
       | l when List.length l < List.length l' ->
           let candidates = List.map fst l in
           restrict_evar evd evk None (UpdateWith candidates)
-- 
cgit v1.2.3


From c23f0cab6ee1e9c9b63347cd2624b64591871cb1 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 7 Nov 2015 22:17:04 +0100
Subject: Experimenting printing the type of the defined term of a LetIn when
 this type is a proposition. This is based on the assumption that in Prop,
 what matters first is the statement.

---
 pretyping/detyping.ml | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index b5228094a2..df15be9b30 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -661,7 +661,13 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
   match bk with
   | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
   | BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
-  | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r)
+  | BLetIn ->
+      let c = detype (lax,false) avoid env sigma (Option.get body) in
+      (* Heuristic: we display the type if in Prop *)
+      let s = Retyping.get_sort_family_of (snd env) sigma ty in
+      let c = if s != InProp then c else
+          GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in
+      GLetIn (dl, na', c, r)
 
 let detype_rel_context ?(lax=false) where avoid env sigma sign =
   let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
-- 
cgit v1.2.3


From b3aba0467a99ce8038816b845cf883be3521fce8 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 9 Nov 2015 13:39:00 +0100
Subject: Pushing the backtrace in conversion anomalies.

---
 pretyping/reductionops.ml | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 0714c93b4f..156c9a2772 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1251,13 +1251,18 @@ let pb_equal = function
   | Reduction.CUMUL -> Reduction.CONV
   | Reduction.CONV -> Reduction.CONV
 
+let report_anomaly _ =
+  let e = UserError ("", Pp.str "Conversion test raised an anomaly") in
+  let e = Errors.push e in
+  iraise e
+
 let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
   try
     let evars ev = safe_evar_value sigma ev in
     let _ = f ~evars reds env (Evd.universes sigma) x y in
     true
   with Reduction.NotConvertible -> false
-    | e when is_anomaly e -> error "Conversion test raised an anomaly"
+    | e when is_anomaly e -> report_anomaly e
 
 let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma
 let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma
@@ -1275,7 +1280,7 @@ let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y
     try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
     with Reduction.NotConvertible -> false
     | Univ.UniverseInconsistency _ -> false
-    | e when is_anomaly e -> error "Conversion test raised an anomaly"
+    | e when is_anomaly e -> report_anomaly e
 
 let sigma_compare_sorts env pb s0 s1 sigma =
   match pb with
@@ -1316,7 +1321,7 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
   with
   | Reduction.NotConvertible -> sigma, false
   | Univ.UniverseInconsistency _ when catch_incon -> sigma, false
-  | e when is_anomaly e -> error "Conversion test raised an anomaly"
+  | e when is_anomaly e -> report_anomaly e
 
 let infer_conv = infer_conv_gen (fun pb ~l2r sigma ->
       Reduction.generic_conv pb ~l2r (safe_evar_value sigma))
-- 
cgit v1.2.3


From 07620386b3c1b535ee7e43306a6345f015a318f0 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Mon, 31 Aug 2015 20:53:45 +0200
Subject: Fixing #1225: we now skip the canonically built binding contexts of
 the return clause and of the branches in a "match", computing them
 automatically when using the "at" clause of pattern, destruct, ...

In principle, this is a source of incompatibilities in the numbering,
since the internal binders of a "match" are now skipped. We shall deal
with that later on.
---
 pretyping/find_subterm.ml  | 81 ++++++++++++++++++++++++++++++++++------------
 pretyping/find_subterm.mli |  5 +--
 pretyping/unification.ml   | 13 ++++----
 3 files changed, 71 insertions(+), 28 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 95a6ba79db..c8d90fffea 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -14,6 +14,8 @@ open Locus
 open Term
 open Nameops
 open Termops
+open Environ
+open Inductiveops
 open Pretype_errors
 
 (** Processing occurrences *)
@@ -73,6 +75,17 @@ let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
       let acc,typ = f acc typ in
       acc,(id,Some body,typ)
 
+let rec process_under_binders f envk sign p =
+  let rec aux (env,k) sign p =
+    match (sign,kind_of_term p) with
+    | [], _ -> f (env,k) p
+    | (_,None,t as d)::sign, Lambda (na,_,p) ->
+      mkLambda (na,t,aux (push_rel d env,k+1) sign p)
+    | (_,(Some c),t as d)::sign, LetIn (na,_,_,p) ->
+      mkLetIn (na,c,t,aux (push_rel d env,k+1) sign p)
+    | _ -> assert false
+  in aux envk (List.rev sign) p
+
 (** Finding a subterm up to some testing function *)
 
 exception SubtermUnificationError of subterm_unification_error
@@ -82,6 +95,7 @@ exception NotUnifiable of (constr * constr * unification_error) option
 type 'a testing_function = {
   match_fun : 'a -> constr -> 'a;
   merge_fun : 'a -> 'a -> 'a;
+  get_evars : 'a -> Evd.evar_map;
   mutable testing_state : 'a;
   mutable last_found : position_reporting option
 }
@@ -91,7 +105,7 @@ type 'a testing_function = {
    (b,l), b=true means no occurrence except the ones in l and b=false,
    means all occurrences except the ones in l *)
 
-let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
+let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t =
   let (nowhere_except_in,locs) = Locusops.convert_occs occs in
   let maxocc = List.fold_right max locs 0 in
   let pos = ref occ in
@@ -103,9 +117,9 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
     with NotUnifiable e when not like_first ->
       let lastpos = Option.get test.last_found in
      raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in
-  let rec substrec k t =
+  let rec substrec (env,k) t =
     if nowhere_except_in && !pos > maxocc then t else
-    if not (Vars.closed0 t) then subst_below k t else
+    if not (Vars.closed0 t) then subst_below (env,k) t else
     try
       let subst = test.match_fun test.testing_state t in
       if Locusops.is_selected !pos occs then
@@ -118,31 +132,51 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
          add_subst t subst; incr pos;
          (* Check nested matching subterms *)
          if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then
-           begin nested := true; ignore (subst_below k t); nested := false end;
+           begin nested := true; ignore (subst_below (env,k) t); nested := false end;
          (* Do the effective substitution *)
          Vars.lift k (bywhat ()))
       else
-        (incr pos; subst_below k t)
+        (incr pos; subst_below (env,k) t)
     with NotUnifiable _ ->
-      subst_below k t
-  and subst_below k t =
-    map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t
-  in
-  let t' = substrec 0 t in
+      subst_below (env,k) t
+  and subst_below (env,k) t =
+    match kind_of_term t with
+    | Case (ci,p,c,br) ->
+      let c = substrec (env,k) c in
+      let sigma = test.get_evars test.testing_state in
+      let t = Retyping.get_type_of env sigma c in
+      let IndType (indf,_) = find_rectype env sigma t in
+      let p = subst_cases_predicate (env,k) indf p in
+      let cstrs = get_constructors env indf in
+      let br = Array.map2 (subst_cases_branch (env,k) indf) br cstrs in
+      mkCase (ci,p,c,br)
+    | _ ->
+      map_constr_with_binders_left_to_right (fun d (env,k) -> (push_rel d env,k+1))
+        substrec (env,k) t
+  and subst_cases_predicate (env,k) indf p =
+    let arsign,_ = get_arity env indf in
+    let nrealargs = List.length arsign in
+    let (ind,params) = dest_ind_family indf in
+    let mind = applist (mkIndU ind,
+       (List.map (Vars.lift nrealargs) params)@(extended_rel_list 0 arsign)) in
+    process_under_binders substrec (env,k) ((Anonymous,None,mind)::arsign) p
+  and subst_cases_branch (env,k) indf b cstr =
+    process_under_binders substrec (env,k) cstr.cs_args b in
+  let t' = substrec (env,0) t in
   (!pos, t')
 
-let replace_term_occ_modulo occs test bywhat t =
+let replace_term_occ_modulo occs test bywhat env t =
   let occs',like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in
   proceed_with_occurrences
-    (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t
+    (replace_term_occ_gen_modulo occs' like_first test bywhat env None) occs' t
 
-let replace_term_occ_decl_modulo occs test bywhat d =
+let replace_term_occ_decl_modulo occs test bywhat env d =
   let (plocs,hyploc),like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
   proceed_with_occurrences
     (map_named_declaration_with_hyploc
-       (replace_term_occ_gen_modulo plocs like_first test bywhat)
+       (replace_term_occ_gen_modulo plocs like_first test bywhat env)
        hyploc)
     plocs d
 
@@ -156,23 +190,30 @@ let make_eq_univs_test env evd c =
 	with Evd.UniversesDiffer -> raise (NotUnifiable None)
       else raise (NotUnifiable None));
   merge_fun = (fun evd _ -> evd);
+  get_evars = (fun evd -> evd);
   testing_state = evd;
   last_found = None
 } 
 
-let subst_closed_term_occ env evd occs c t =
-  let test = make_eq_univs_test env evd c in
+let subst_closed_term_occ env sigma occs c t =
+  let test = make_eq_univs_test env sigma c in
   let bywhat () = mkRel 1 in
-  let t' = replace_term_occ_modulo occs test bywhat t in
+  let typ = Retyping.get_type_of env sigma c in
+  assert (rel_context env == []);
+  let env = push_rel (Anonymous,Some c,typ) env in
+  let t' = replace_term_occ_modulo occs test bywhat env t in
     t', test.testing_state
 
-let subst_closed_term_occ_decl env evd occs c d =
-  let test = make_eq_univs_test env evd c in
+let subst_closed_term_occ_decl env sigma occs c d =
+  let test = make_eq_univs_test env sigma c in
   let (plocs,hyploc),like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
   let bywhat () = mkRel 1 in
+  let typ = Retyping.get_type_of env sigma c in
+  assert (rel_context env == []);
+  let env = push_rel (Anonymous,Some c,typ) env in
   proceed_with_occurrences
     (map_named_declaration_with_hyploc
-       (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None)
+       (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat env None)
        hyploc) plocs d,
   test.testing_state
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 47d9654e57..23d7ed9498 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -29,6 +29,7 @@ exception SubtermUnificationError of subterm_unification_error
 type 'a testing_function = {
   match_fun : 'a -> constr -> 'a;
   merge_fun : 'a -> 'a -> 'a;
+  get_evars : 'a -> evar_map;
   mutable testing_state : 'a;
   mutable last_found : position_reporting option
 }
@@ -43,14 +44,14 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function
     ()]; it turns a NotUnifiable exception raised by the testing
     function into a SubtermUnificationError. *)
 val replace_term_occ_modulo : occurrences or_like_first ->
-  'a testing_function -> (unit -> constr) -> constr -> constr
+  'a testing_function -> (unit -> constr) -> env -> constr -> constr
 
 (** [replace_term_occ_decl_modulo] is similar to
     [replace_term_occ_modulo] but for a named_declaration. *)
 val replace_term_occ_decl_modulo :
   (occurrences * hyp_location_flag) or_like_first ->
   'a testing_function -> (unit -> constr) ->
-  named_declaration -> named_declaration
+  env -> named_declaration -> named_declaration
 
 (** [subst_closed_term_occ occl c d] replaces occurrences of
     closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 269c723e30..002fd0c025 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1530,6 +1530,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
     | None, Some _ -> c2
     | None, None -> None in
   { match_fun = matching_fun; merge_fun = merge_fun;
+    get_evars = (function None -> sigma | Some (evd,_,_) -> evd);
     testing_state = None; last_found = None },
   (fun test -> match test.testing_state with
   | None -> None
@@ -1545,8 +1546,8 @@ let make_eq_test env evd c =
   (make_eq_univs_test env evd c, out)
 
 let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
+  let t = match ty with Some t -> t | None -> get_type_of env sigma c in
   let id =
-    let t = match ty with Some t -> t | None -> get_type_of env sigma c in
     let x = id_of_name_using_hdchar (Global.env()) t name in
     let ids = ids_of_named_context (named_context env) in
     if name == Anonymous then next_ident_away_in_goal x ids else
@@ -1554,8 +1555,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
       errorlabstrm "Unification.make_abstraction_core"
         (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.")
     else
-      x
-  in
+      x in
+  let env' = push_named (id, Some c, t) env in
   let likefirst = clause_with_generic_occurrences occs in
   let mkvarid () = mkVar id in
   let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
@@ -1571,7 +1572,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           (push_named_context_val d sign,depdecls)
     | AllOccurrences, InHyp as occ ->
         let occ = if likefirst then LikeFirst else AtOccs occ in
-        let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
+        let newdecl = replace_term_occ_decl_modulo occ test mkvarid env' d in
         if Context.eq_named_declaration d newdecl
            && not (indirectly_dependent c d depdecls)
         then
@@ -1582,7 +1583,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           (push_named_context_val newdecl sign, newdecl :: depdecls)
     | occ ->
         (* There are specific occurrences, hence not like first *)
-        let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in
+        let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid env' d in
         (push_named_context_val newdecl sign, newdecl :: depdecls) in
   try
     let sign,depdecls =
@@ -1592,7 +1593,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
       | NoOccurrences -> concl
       | occ ->
           let occ = if likefirst then LikeFirst else AtOccs occ in
-          replace_term_occ_modulo occ test mkvarid concl
+          replace_term_occ_modulo occ test mkvarid env' concl
     in
     let lastlhyp =
       if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
-- 
cgit v1.2.3


From d57e30cfe8f68987ed216415079f4dab42065408 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Tue, 10 Nov 2015 17:26:36 +0100
Subject: Revert "Fixing #1225: we now skip the canonically built binding
 contexts of"

This reverts commit 07620386b3c1b535ee7e43306a6345f015a318f0.

Very sorry not ready.
---
 pretyping/find_subterm.ml  | 81 ++++++++++++----------------------------------
 pretyping/find_subterm.mli |  5 ++-
 pretyping/unification.ml   | 13 ++++----
 3 files changed, 28 insertions(+), 71 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index c8d90fffea..95a6ba79db 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -14,8 +14,6 @@ open Locus
 open Term
 open Nameops
 open Termops
-open Environ
-open Inductiveops
 open Pretype_errors
 
 (** Processing occurrences *)
@@ -75,17 +73,6 @@ let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
       let acc,typ = f acc typ in
       acc,(id,Some body,typ)
 
-let rec process_under_binders f envk sign p =
-  let rec aux (env,k) sign p =
-    match (sign,kind_of_term p) with
-    | [], _ -> f (env,k) p
-    | (_,None,t as d)::sign, Lambda (na,_,p) ->
-      mkLambda (na,t,aux (push_rel d env,k+1) sign p)
-    | (_,(Some c),t as d)::sign, LetIn (na,_,_,p) ->
-      mkLetIn (na,c,t,aux (push_rel d env,k+1) sign p)
-    | _ -> assert false
-  in aux envk (List.rev sign) p
-
 (** Finding a subterm up to some testing function *)
 
 exception SubtermUnificationError of subterm_unification_error
@@ -95,7 +82,6 @@ exception NotUnifiable of (constr * constr * unification_error) option
 type 'a testing_function = {
   match_fun : 'a -> constr -> 'a;
   merge_fun : 'a -> 'a -> 'a;
-  get_evars : 'a -> Evd.evar_map;
   mutable testing_state : 'a;
   mutable last_found : position_reporting option
 }
@@ -105,7 +91,7 @@ type 'a testing_function = {
    (b,l), b=true means no occurrence except the ones in l and b=false,
    means all occurrences except the ones in l *)
 
-let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t =
+let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
   let (nowhere_except_in,locs) = Locusops.convert_occs occs in
   let maxocc = List.fold_right max locs 0 in
   let pos = ref occ in
@@ -117,9 +103,9 @@ let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t =
     with NotUnifiable e when not like_first ->
       let lastpos = Option.get test.last_found in
      raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in
-  let rec substrec (env,k) t =
+  let rec substrec k t =
     if nowhere_except_in && !pos > maxocc then t else
-    if not (Vars.closed0 t) then subst_below (env,k) t else
+    if not (Vars.closed0 t) then subst_below k t else
     try
       let subst = test.match_fun test.testing_state t in
       if Locusops.is_selected !pos occs then
@@ -132,51 +118,31 @@ let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t =
          add_subst t subst; incr pos;
          (* Check nested matching subterms *)
          if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then
-           begin nested := true; ignore (subst_below (env,k) t); nested := false end;
+           begin nested := true; ignore (subst_below k t); nested := false end;
          (* Do the effective substitution *)
          Vars.lift k (bywhat ()))
       else
-        (incr pos; subst_below (env,k) t)
+        (incr pos; subst_below k t)
     with NotUnifiable _ ->
-      subst_below (env,k) t
-  and subst_below (env,k) t =
-    match kind_of_term t with
-    | Case (ci,p,c,br) ->
-      let c = substrec (env,k) c in
-      let sigma = test.get_evars test.testing_state in
-      let t = Retyping.get_type_of env sigma c in
-      let IndType (indf,_) = find_rectype env sigma t in
-      let p = subst_cases_predicate (env,k) indf p in
-      let cstrs = get_constructors env indf in
-      let br = Array.map2 (subst_cases_branch (env,k) indf) br cstrs in
-      mkCase (ci,p,c,br)
-    | _ ->
-      map_constr_with_binders_left_to_right (fun d (env,k) -> (push_rel d env,k+1))
-        substrec (env,k) t
-  and subst_cases_predicate (env,k) indf p =
-    let arsign,_ = get_arity env indf in
-    let nrealargs = List.length arsign in
-    let (ind,params) = dest_ind_family indf in
-    let mind = applist (mkIndU ind,
-       (List.map (Vars.lift nrealargs) params)@(extended_rel_list 0 arsign)) in
-    process_under_binders substrec (env,k) ((Anonymous,None,mind)::arsign) p
-  and subst_cases_branch (env,k) indf b cstr =
-    process_under_binders substrec (env,k) cstr.cs_args b in
-  let t' = substrec (env,0) t in
+      subst_below k t
+  and subst_below k t =
+    map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t
+  in
+  let t' = substrec 0 t in
   (!pos, t')
 
-let replace_term_occ_modulo occs test bywhat env t =
+let replace_term_occ_modulo occs test bywhat t =
   let occs',like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in
   proceed_with_occurrences
-    (replace_term_occ_gen_modulo occs' like_first test bywhat env None) occs' t
+    (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t
 
-let replace_term_occ_decl_modulo occs test bywhat env d =
+let replace_term_occ_decl_modulo occs test bywhat d =
   let (plocs,hyploc),like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
   proceed_with_occurrences
     (map_named_declaration_with_hyploc
-       (replace_term_occ_gen_modulo plocs like_first test bywhat env)
+       (replace_term_occ_gen_modulo plocs like_first test bywhat)
        hyploc)
     plocs d
 
@@ -190,30 +156,23 @@ let make_eq_univs_test env evd c =
 	with Evd.UniversesDiffer -> raise (NotUnifiable None)
       else raise (NotUnifiable None));
   merge_fun = (fun evd _ -> evd);
-  get_evars = (fun evd -> evd);
   testing_state = evd;
   last_found = None
 } 
 
-let subst_closed_term_occ env sigma occs c t =
-  let test = make_eq_univs_test env sigma c in
+let subst_closed_term_occ env evd occs c t =
+  let test = make_eq_univs_test env evd c in
   let bywhat () = mkRel 1 in
-  let typ = Retyping.get_type_of env sigma c in
-  assert (rel_context env == []);
-  let env = push_rel (Anonymous,Some c,typ) env in
-  let t' = replace_term_occ_modulo occs test bywhat env t in
+  let t' = replace_term_occ_modulo occs test bywhat t in
     t', test.testing_state
 
-let subst_closed_term_occ_decl env sigma occs c d =
-  let test = make_eq_univs_test env sigma c in
+let subst_closed_term_occ_decl env evd occs c d =
+  let test = make_eq_univs_test env evd c in
   let (plocs,hyploc),like_first =
     match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
   let bywhat () = mkRel 1 in
-  let typ = Retyping.get_type_of env sigma c in
-  assert (rel_context env == []);
-  let env = push_rel (Anonymous,Some c,typ) env in
   proceed_with_occurrences
     (map_named_declaration_with_hyploc
-       (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat env None)
+       (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None)
        hyploc) plocs d,
   test.testing_state
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 23d7ed9498..47d9654e57 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -29,7 +29,6 @@ exception SubtermUnificationError of subterm_unification_error
 type 'a testing_function = {
   match_fun : 'a -> constr -> 'a;
   merge_fun : 'a -> 'a -> 'a;
-  get_evars : 'a -> evar_map;
   mutable testing_state : 'a;
   mutable last_found : position_reporting option
 }
@@ -44,14 +43,14 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function
     ()]; it turns a NotUnifiable exception raised by the testing
     function into a SubtermUnificationError. *)
 val replace_term_occ_modulo : occurrences or_like_first ->
-  'a testing_function -> (unit -> constr) -> env -> constr -> constr
+  'a testing_function -> (unit -> constr) -> constr -> constr
 
 (** [replace_term_occ_decl_modulo] is similar to
     [replace_term_occ_modulo] but for a named_declaration. *)
 val replace_term_occ_decl_modulo :
   (occurrences * hyp_location_flag) or_like_first ->
   'a testing_function -> (unit -> constr) ->
-  env -> named_declaration -> named_declaration
+  named_declaration -> named_declaration
 
 (** [subst_closed_term_occ occl c d] replaces occurrences of
     closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 002fd0c025..269c723e30 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1530,7 +1530,6 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
     | None, Some _ -> c2
     | None, None -> None in
   { match_fun = matching_fun; merge_fun = merge_fun;
-    get_evars = (function None -> sigma | Some (evd,_,_) -> evd);
     testing_state = None; last_found = None },
   (fun test -> match test.testing_state with
   | None -> None
@@ -1546,8 +1545,8 @@ let make_eq_test env evd c =
   (make_eq_univs_test env evd c, out)
 
 let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
-  let t = match ty with Some t -> t | None -> get_type_of env sigma c in
   let id =
+    let t = match ty with Some t -> t | None -> get_type_of env sigma c in
     let x = id_of_name_using_hdchar (Global.env()) t name in
     let ids = ids_of_named_context (named_context env) in
     if name == Anonymous then next_ident_away_in_goal x ids else
@@ -1555,8 +1554,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
       errorlabstrm "Unification.make_abstraction_core"
         (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.")
     else
-      x in
-  let env' = push_named (id, Some c, t) env in
+      x
+  in
   let likefirst = clause_with_generic_occurrences occs in
   let mkvarid () = mkVar id in
   let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
@@ -1572,7 +1571,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           (push_named_context_val d sign,depdecls)
     | AllOccurrences, InHyp as occ ->
         let occ = if likefirst then LikeFirst else AtOccs occ in
-        let newdecl = replace_term_occ_decl_modulo occ test mkvarid env' d in
+        let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
         if Context.eq_named_declaration d newdecl
            && not (indirectly_dependent c d depdecls)
         then
@@ -1583,7 +1582,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           (push_named_context_val newdecl sign, newdecl :: depdecls)
     | occ ->
         (* There are specific occurrences, hence not like first *)
-        let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid env' d in
+        let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in
         (push_named_context_val newdecl sign, newdecl :: depdecls) in
   try
     let sign,depdecls =
@@ -1593,7 +1592,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
       | NoOccurrences -> concl
       | occ ->
           let occ = if likefirst then LikeFirst else AtOccs occ in
-          replace_term_occ_modulo occ test mkvarid env' concl
+          replace_term_occ_modulo occ test mkvarid concl
     in
     let lastlhyp =
       if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
-- 
cgit v1.2.3


From 2f56f0fcf21902bb1317f1d6f7ba4b593d712646 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 5 Nov 2015 16:04:43 -0500
Subject: Fix bug #4293: ensure let-ins do not contain algebraic universes in
 their type annotation.

---
 pretyping/evarsolve.ml  | 10 ++++++----
 pretyping/evarsolve.mli |  3 ++-
 pretyping/pretyping.ml  |  4 +++-
 3 files changed, 11 insertions(+), 6 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 35bc1de593..aeb2445d1c 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -47,7 +47,7 @@ let refresh_level evd s =
   | None -> true
   | Some l -> not (Evd.is_flexible_level evd l)
 
-let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
+let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
   let evdref = ref evd in
   let modified = ref false in
   let rec refresh status dir t = 
@@ -98,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
     if isArity t then
       (match pbty with
       | None -> t
-      | Some dir -> refresh univ_rigid dir t)
+      | Some dir -> refresh status dir t)
     else (refresh_term_evars false true t; t)
   in
     if !modified then !evdref, t' else !evdref, t
@@ -609,7 +609,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
       let id = next_name_away na avoid in
       let evd,t_in_sign =
         let s = Retyping.get_sort_of env evd t_in_env in
-        let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in
+        let evd,ty_t_in_sign = refresh_universes
+	 ~status:univ_flexible (Some false) env evd (mkSort s) in
         define_evar_from_virtual_equation define_fun env evd src t_in_env
           ty_t_in_sign sign filter inst_in_env in
       let evd,b_in_sign = match b with
@@ -627,7 +628,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
   in
   let evd,ev2ty_in_sign =
     let s = Retyping.get_sort_of env evd ty_in_env in
-    let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in
+    let evd,ty_t_in_sign = refresh_universes
+     ~status:univ_flexible (Some false) env evd (mkSort s) in
     define_evar_from_virtual_equation define_fun env evd src ty_in_env
       ty_t_in_sign sign2 filter2 inst2_in_env in
   let evd,ev2_in_sign =
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index 21d976091f..86a1e3e0ce 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -34,7 +34,8 @@ type conv_fun_bool =
 val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> 
   bool option -> existential -> constr -> evar_map
 
-val refresh_universes : ?inferred:bool -> ?onlyalg:bool (* Only algebraic universes *) ->
+val refresh_universes : ?status:Evd.rigid ->
+			?onlyalg:bool (* Only algebraic universes *) ->
   bool option (* direction: true for levels lower than the existing levels *) ->
   env -> evar_map -> types -> evar_map * types
 
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index d354a6c3c4..dd4fcf1981 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -739,7 +739,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	  pretype (mk_tycon tj.utj_val) env evdref lvar c
       | _ -> pretype empty_tycon env evdref lvar c1
     in
-    let t = j.uj_type in
+    let t = evd_comb1 (Evarsolve.refresh_universes
+      ~onlyalg:true ~status:Evd.univ_flexible (Some false) env)
+      evdref j.uj_type in
     (* The name specified by ltac is used also to create bindings. So
        the substitution must also be applied on variables before they are
        looked up in the rel context. *)
-- 
cgit v1.2.3


From a3f0a0daf58964a54b1e6fb1f8252f68a8c9c8ea Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 5 Nov 2015 17:47:39 -0500
Subject: Fix bug #3998: when using typeclass resolution for conversion, allow
 only one disjoint component of the typeclasses instances to resolve.

---
 pretyping/coercion.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index e61e52c178..3163ac0e6e 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -343,7 +343,7 @@ let coerce_itf loc env evd v t c1 =
 
 let saturate_evd env evd =
   Typeclasses.resolve_typeclasses
-    ~filter:Typeclasses.no_goals ~split:false ~fail:false env evd
+    ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd
 
 (* Apply coercion path from p to hj; raise NoCoercion if not applicable *)
 let apply_coercion env sigma p hj typ_cl =
-- 
cgit v1.2.3


From 834876a3e07fe8053aa99655f21883c3e8927a8c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 6 Nov 2015 17:52:53 -0500
Subject: Ensure that conversion is called on terms of the same type in
 unification (not necessarily preserved due to the fo approximation rule).

---
 pretyping/unification.ml | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 24e06007e9..9758aa43c4 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -904,8 +904,18 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
       match subst_defined_metas_evars subst cN with
       | None -> (* some undefined Metas in cN *) None
       | Some n1 ->
-          (* No subterm restriction there, too much incompatibilities *)
-	  let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in
+         (* No subterm restriction there, too much incompatibilities *)
+	 let sigma =
+	   if opt.with_types then
+	     try (* Ensure we call conversion on terms of the same type *)
+	       let tyM = get_type_of curenv ~lax:true sigma m1 in
+	       let tyN = get_type_of curenv ~lax:true sigma n1 in
+	       check_compatibility curenv CUMUL flags substn tyM tyN
+	     with RetypeError _ ->
+	       (* Renounce, maybe metas/evars prevents typing *) sigma
+	   else sigma
+	 in 
+	 let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in
 	    if b then Some (sigma, metasubst, evarsubst)
 	    else 
 	      if is_ground_term sigma m1 && is_ground_term sigma n1 then
-- 
cgit v1.2.3


From af399d81b0505d1f0be8e73cf45044266d5749e5 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Tue, 17 Nov 2015 12:39:35 +0100
Subject: Performance fix for destruct.

The clenv_fchain function was needlessly merging universes coming from
two evarmaps even though one was an extension of the other. A flag was
added so that the tactic just retrieves the newer universes.
---
 pretyping/evd.ml  | 7 +++++--
 pretyping/evd.mli | 2 +-
 2 files changed, 6 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 4a9466f4f3..c9b9f34414 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1550,9 +1550,12 @@ let meta_with_name evd id =
 
 let clear_metas evd = {evd with metas = Metamap.empty}
 
-let meta_merge evd1 evd2 =
+let meta_merge ?(with_univs = true) evd1 evd2 =
   let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in
-  let universes = union_evar_universe_context evd2.universes evd1.universes in
+  let universes =
+    if with_univs then union_evar_universe_context evd2.universes evd1.universes
+    else evd2.universes
+  in
   {evd2 with universes; metas; }
 
 type metabinding = metavariable * constr * instance_status
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 5c508419a4..117e52958b 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -451,7 +451,7 @@ val meta_reassign  : metavariable -> constr * instance_status -> evar_map -> eva
 val clear_metas : evar_map -> evar_map
 
 (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
-val meta_merge : evar_map -> evar_map -> evar_map
+val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map
 
 val undefined_metas : evar_map -> metavariable list
 val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
-- 
cgit v1.2.3


From 9d47cc0af706ed1cd4ab87c2d402a0457a9b6a5c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 19 Nov 2015 17:48:32 +0100
Subject: Fix bug #4433, removing hack on evars appearing in a pattern from a
 constr, and the associated signature, not needed anymore. Update CHANGES, no
 evar_map is produced by pattern_of_constr anymore.

---
 pretyping/patternops.ml  | 29 +++++++----------------------
 pretyping/patternops.mli |  3 +--
 2 files changed, 8 insertions(+), 24 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index fb629d049f..83bf355cc2 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -122,9 +122,6 @@ let head_of_constr_reference c = match kind_of_term c with
   | _ -> anomaly (Pp.str "Not a rigid reference")
 
 let pattern_of_constr env sigma t =
-  let ctx = ref [] in
-  let keep = ref Evar.Set.empty in
-  let remove = ref Evar.Set.empty in
   let rec pattern_of_constr env t =
   match kind_of_term t with
     | Rel n  -> PRel n
@@ -143,14 +140,9 @@ let pattern_of_constr env sigma t =
     | App (f,a) ->
         (match
           match kind_of_term f with
-          | Evar (evk,args as ev) ->
+          | Evar (evk,args) ->
             (match snd (Evd.evar_source evk sigma) with
-              Evar_kinds.MatchingVar (true,id) ->
-		let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in
-                  ctx := (id,None,ty)::!ctx;
-		  keep := Evar.Set.union (evars_of_term ty) !keep;
-		  remove := Evar.Set.add evk !remove;
-                  Some id
+              Evar_kinds.MatchingVar (true,id) -> Some id
             | _ -> None)
           | _ -> None
          with
@@ -162,13 +154,11 @@ let pattern_of_constr env sigma t =
     | Proj (p, c) -> 
       pattern_of_constr env (Retyping.expand_projection env sigma p c [])
     | Evar (evk,ctxt as ev) ->
-      remove := Evar.Set.add evk !remove;
       (match snd (Evd.evar_source evk sigma) with
       | Evar_kinds.MatchingVar (b,id) ->
 	let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in
-          ctx := (id,None,ty)::!ctx;
-	  let () = ignore (pattern_of_constr env ty) in
-          assert (not b); PMeta (Some id)
+	let () = ignore (pattern_of_constr env ty) in
+        assert (not b); PMeta (Some id)
       | Evar_kinds.GoalEvar -> 
 	PEvar (evk,Array.map (pattern_of_constr env) ctxt)
       | _ -> 
@@ -189,12 +179,7 @@ let pattern_of_constr env sigma t =
 	       Array.to_list (Array.mapi branch_of_constr br))
     | Fix f -> PFix f
     | CoFix f -> PCoFix f in
-  let p = pattern_of_constr env t in
-  let remove = Evar.Set.diff !remove !keep in
-  let sigma = Evar.Set.fold (fun ev acc -> Evd.remove acc ev) remove sigma in
-  (* side-effect *)
-  (* Warning: the order of dependencies in ctx is not ensured *)
-  (sigma,!ctx,p)
+  pattern_of_constr env t
 
 (* To process patterns, we need a translation without typing at all. *)
 
@@ -234,7 +219,7 @@ let instantiate_pattern env sigma lvar c =
               ctx
           in
 	  let c = substl inst c in
-	  pi3 (pattern_of_constr env sigma c)
+	  pattern_of_constr env sigma c
 	with Not_found (* List.index failed *) ->
 	  let vars =
 	    List.map_filter (function Name id -> Some id | _ -> None) vars in
@@ -259,7 +244,7 @@ let rec subst_pattern subst pat =
   | PRef ref ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then pat else
-	 pi3 (pattern_of_constr (Global.env()) Evd.empty t)
+	 pattern_of_constr (Global.env()) Evd.empty t
   | PVar _
   | PEvar _
   | PRel _ -> pat
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 9e72280fe2..0148280287 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -39,8 +39,7 @@ val head_of_constr_reference : Term.constr -> global_reference
    a pattern; currently, no destructor (Cases, Fix, Cofix) and no
    existential variable are allowed in [c] *)
 
-val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> 
-  Evd.evar_map * named_context * constr_pattern
+val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> constr_pattern
 
 (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into
    a pattern; variables bound in [l] are replaced by the pattern to which they
-- 
cgit v1.2.3


From e583a79b5a0298fd08f34305cc876d5117913e95 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 21 Nov 2015 00:23:12 +0100
Subject: Fixing kernel bug in typing match with let-ins in the arity.

Was exploitable in 8.3, 8.4 and 8.5beta1. A priori not exploitable in
8.5beta2 and 8.5beta3 from a Coq file because typing done while
compiling "match" would serve as a protection. However exploitable by
calling the kernel directly, e.g. from a plugin (but a plugin can
anyway do what it wants by bypassing kernel type abstraction).

Fixing similar error in pretyping.
---
 pretyping/reductionops.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 156c9a2772..bdd9ed81cf 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1651,7 +1651,7 @@ let betazetaevar_applist sigma n c l =
     if Int.equal n 0 then applist (substl env t, stack) else
     match kind_of_term t, stack with
     | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
-    | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack
+    | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack
     | Evar ev, _ ->
       (match safe_evar_value sigma ev with
       | Some body -> stacklam n env body stack
-- 
cgit v1.2.3


From af954522789043202d9c300a0bb37cbaf4958d60 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 22 Nov 2015 17:17:49 +0100
Subject: Fixing a bug of adjust_subst_to_rel_context.

---
 pretyping/termops.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 5a55d47fd1..ebd9d939aa 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -930,7 +930,7 @@ let adjust_subst_to_rel_context sign l =
     match sign, l with
     | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args'
     | (_,Some c,_)::sign', args' ->
-	aux (substl (List.rev subst) c :: subst) sign' args'
+	aux (substl subst c :: subst) sign' args'
     | [], [] -> List.rev subst
     | _ -> anomaly (Pp.str "Instance and signature do not match")
   in aux [] (List.rev sign) l
-- 
cgit v1.2.3


From c4e2cf027b3fade4f9c2806e6061e1294a99e540 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 22 Nov 2015 21:17:59 +0100
Subject: Fixing a vm_compute bug in the presence of let-ins among the
 parameters of an inductive type.

---
 pretyping/vnorm.ml | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index c4c85a62ed..be772a6677 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -59,11 +59,12 @@ let type_constructor mind mib u typ params =
   let s = ind_subst mind mib u in
   let ctyp = substl s typ in
   let ctyp = subst_instance_constr u ctyp in
-  let nparams = Array.length params in
-  if Int.equal nparams 0 then ctyp
+  let ndecls = Context.rel_context_length mib.mind_params_ctxt in
+  if Int.equal ndecls 0 then ctyp
   else
-    let _,ctyp = decompose_prod_n nparams ctyp in
-    substl (Array.rev_to_list params) ctyp
+    let _,ctyp = decompose_prod_n_assum ndecls ctyp in
+    substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
+      ctyp
 
 
 
-- 
cgit v1.2.3


From 1467c22548453cd07ceba0029e37c8bbdfd039ea Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Mon, 23 Nov 2015 17:51:16 +0100
Subject: Fixing an old typo in Retyping, found by Matej.

---
 pretyping/retyping.ml | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index fb55265526..a169a4577e 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -158,8 +158,7 @@ let retype ?(polyprop=true) sigma =
   and sort_family_of env t =
     match kind_of_term t with
     | Cast (c,_, s) when isSort s -> family_of_sort (destSort s)
-    | Sort (Prop c) -> InType
-    | Sort (Type u) -> InType
+    | Sort s -> family_of_sort s
     | Prod (name,t,c2) ->
 	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
 	if not (is_impredicative_set env) &&
-- 
cgit v1.2.3


From e92aeed3abcf7d42045deb9fb3a450d3527eadc9 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Wed, 25 Nov 2015 17:33:24 +0100
Subject: Reverting 1467c225 (Fixing an old typo in Retyping, found by Matej).

This was not a typo (was correctly taking the family type of the type).
---
 pretyping/retyping.ml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index a169a4577e..fb55265526 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -158,7 +158,8 @@ let retype ?(polyprop=true) sigma =
   and sort_family_of env t =
     match kind_of_term t with
     | Cast (c,_, s) when isSort s -> family_of_sort (destSort s)
-    | Sort s -> family_of_sort s
+    | Sort (Prop c) -> InType
+    | Sort (Type u) -> InType
     | Prod (name,t,c2) ->
 	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
 	if not (is_impredicative_set env) &&
-- 
cgit v1.2.3


From 103ec7205d9038f1f3821f9287e3bb0907a1e3ec Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Thu, 19 Nov 2015 13:36:31 +0100
Subject: More efficient implementation of equality-up-to-universes in
 Universes.

Instead of accumulating constraints which are not present in the original
graph, we parametrize the equality function by a function actually merging
those constraints in the current graph. This prevents doing the work twice.
---
 pretyping/evarutil.ml     | 13 +++++++------
 pretyping/reductionops.ml | 19 +++++++++++--------
 2 files changed, 18 insertions(+), 14 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 508b9e8027..3c3afac54e 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -860,13 +860,14 @@ let kind_of_term_upto sigma t =
 let eq_constr_univs_test sigma1 sigma2 t u =
   (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
   let open Evd in
-  let b, c =
+  let fold cstr sigma =
+    try Some (add_universe_constraints sigma cstr)
+    with Univ.UniverseInconsistency _ | UniversesDiffer -> None
+  in
+  let ans =
     Universes.eq_constr_univs_infer_with
       (fun t -> kind_of_term_upto sigma1 t)
       (fun u -> kind_of_term_upto sigma2 u)
-      (universes sigma2) t u
+      (universes sigma2) fold t u sigma2
   in
-  if b then
-    try let _ = add_universe_constraints sigma2 c in true
-    with Univ.UniverseInconsistency _ | UniversesDiffer -> false
-  else false
+  match ans with None -> false | Some _ -> true
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index bdd9ed81cf..d5a93230f3 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1299,18 +1299,21 @@ let sigma_univ_state =
 
 let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
     ?(ts=full_transparent_state) env sigma x y =
-  try 
+  try
+    let fold cstr sigma =
+      try Some (Evd.add_universe_constraints sigma cstr)
+      with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
+    in
     let b, sigma = 
-      let b, cstrs = 
+      let ans =
 	if pb == Reduction.CUMUL then 
-	  Universes.leq_constr_univs_infer (Evd.universes sigma) x y 
+	  Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma
 	else
-	  Universes.eq_constr_univs_infer (Evd.universes sigma) x y 
+	  Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma
       in
-	if b then 
-	  try true, Evd.add_universe_constraints sigma cstrs
-	  with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma
-	else false, sigma
+      match ans with
+      | None -> false, sigma
+      | Some sigma -> true, sigma
     in
       if b then sigma, true
       else
-- 
cgit v1.2.3


From 4a11dc25938f3f009e23f1e7c5fe01b2558928c3 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 27 Nov 2015 20:34:51 +0100
Subject: Univs: entirely disallow instantiation of polymorphic constants with
 Prop levels.

As they are typed assuming all variables are >= Set now, and this was
breaking an invariant in typing. Only one instance in the standard
library was used in Hurkens, which can be avoided easily. This also
avoids displaying unnecessary >= Set constraints everywhere.
---
 pretyping/pretyping.ml | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index dd4fcf1981..faba5c7563 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -394,18 +394,22 @@ let pretype_global loc rigid env evd gr us =
     match us with
     | None -> evd, None
     | Some l -> 
-      let _, ctx = Universes.unsafe_constr_of_global gr in
-      let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in
-      let len = Array.length arr in
-	if len != List.length l then
-	  user_err_loc (loc, "pretype", 
-			str "Universe instance should have length " ++ int len)
-	else
-	  let evd, l' = List.fold_left (fun (evd, univs) l -> 
+       let _, ctx = Universes.unsafe_constr_of_global gr in
+       let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in
+       let len = Array.length arr in
+       if len != List.length l then
+	 user_err_loc (loc, "pretype", 
+		       str "Universe instance should have length " ++ int len)
+       else
+	 let evd, l' = List.fold_left (fun (evd, univs) l -> 
 	    let evd, l = interp_universe_level_name evd l in
 	      (evd, l :: univs)) (evd, []) l
-      in 
-	evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
+	 in
+	 if List.exists (fun l -> Univ.Level.is_prop l) l' then
+	   user_err_loc (loc, "pretype",
+		 str "Universe instances cannot contain Prop, polymorphic" ++
+		   str " universe instances must be greater or equal to Set.");
+	 evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
   in
     Evd.fresh_global ~rigid ?names:instance env evd gr
 
@@ -440,13 +444,15 @@ let pretype_sort evdref = function
 
 let new_type_evar env evdref loc =
   let e, s = 
-    evd_comb0 (fun evd -> Evarutil.new_type_evar env evd univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
+    evd_comb0 (fun evd -> Evarutil.new_type_evar env evd
+      univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
   in e
 
 let get_projection env cst =
   let cb = lookup_constant cst env in
     match cb.Declarations.const_proj with
-    | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> 
+    | Some {Declarations.proj_ind = mind; proj_npars = n;
+	    proj_arg = m; proj_type = ty} -> 
       (cst,mind,n,m,ty)
     | None -> raise Not_found
 
-- 
cgit v1.2.3


From c62eb0470975c9b5960a49a90b49b4aa191efd1c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 2 Dec 2015 15:37:14 +0100
Subject: Add an option to deactivate compatibility printing of primitive
 projections (off by default).

---
 pretyping/detyping.ml | 14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index b5228094a2..67261def0b 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -166,6 +166,18 @@ let _ = declare_bool_option
 	    optread  = print_primproj_params;
 	    optwrite = (:=) print_primproj_params_value }
 
+let print_primproj_compatibility_value = ref true
+let print_primproj_compatibility () = !print_primproj_compatibility_value
+
+let _ = declare_bool_option
+	  { optsync  = true;
+            optdepr  = false;
+	    optname  = "backwards-compatible printing of primitive projections";
+	    optkey   = ["Printing";"Primitive";"Projection";"Compatibility"];
+	    optread  = print_primproj_compatibility;
+	    optwrite = (:=) print_primproj_compatibility_value }
+
+	  
 (* Auxiliary function for MutCase printing *)
 (* [computable] tries to tell if the predicate typing the result is inferable*)
 
@@ -476,7 +488,7 @@ let rec detype flags avoid env sigma t =
 	  GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), 
 		[detype flags avoid env sigma c])
       else 
-	if Projection.unfolded p then
+	if print_primproj_compatibility () && Projection.unfolded p then
 	  (** Print the compatibility match version *)
 	  let c' = 
 	    try 
-- 
cgit v1.2.3


From 38e62610be0386a37172fa5aca44e3b3d2c14b9a Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Fri, 4 Dec 2015 00:09:50 +0100
Subject: Removing dynamic inclusion of constrs in tactic AST.

---
 pretyping/pretyping.ml  | 4 ----
 pretyping/pretyping.mli | 3 ---
 2 files changed, 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 78f134248c..ce6d189855 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -95,10 +95,6 @@ let search_guard loc env possible_indexes fixdefs =
 	 user_err_loc (loc,"search_guard", Pp.str errmsg)
      with Found indexes -> indexes)
 
-(* To embed constr in glob_constr *)
-let ((constr_in : constr -> Dyn.t),
-     (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
-
 (* To force universe name declaration before use *)
 
 let strict_universe_declarations = ref true
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 5f0e19cf2b..f8587d01cd 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -148,9 +148,6 @@ val ise_pretype_gen :
 
 (** To embed constr in glob_constr *)
 
-val constr_in : constr -> Dyn.t
-val constr_out : Dyn.t -> constr
-
 val interp_sort : evar_map -> glob_sort -> evar_map * sorts
 val interp_elimination_sort : glob_sort -> sorts_family
 
-- 
cgit v1.2.3


From f22ad605a14eb14d11b0a1615f7014f2dca3b483 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 22 Nov 2015 17:38:18 +0100
Subject: An example in centralizing similar functions to a common place so
 that cleaning the interfaces is eventually easier. Here, adding
 find_mrectype_vect to simplify vnorm.ml.

---
 pretyping/inductiveops.ml  | 7 +++++--
 pretyping/inductiveops.mli | 1 +
 pretyping/vnorm.ml         | 8 +-------
 3 files changed, 7 insertions(+), 9 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index cb091f2d6f..632e00ed70 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -430,12 +430,15 @@ let extract_mrectype t =
     | Ind ind -> (ind, l)
     | _ -> raise Not_found
 
-let find_mrectype env sigma c =
-  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+let find_mrectype_vect env sigma c =
+  let (t, l) = decompose_appvect (whd_betadeltaiota env sigma c) in
   match kind_of_term t with
     | Ind ind -> (ind, l)
     | _ -> raise Not_found
 
+let find_mrectype env sigma c =
+  let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v)
+
 let find_rectype env sigma c =
   let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
   match kind_of_term t with
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 757599a3ce..9036f521ec 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -159,6 +159,7 @@ val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 (** Raise [Not_found] if not given a valid inductive type *)
 val extract_mrectype : constr -> pinductive * constr list
 val find_mrectype    : env -> evar_map -> types -> pinductive * constr list
+val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array
 val find_rectype     : env -> evar_map -> types -> inductive_type
 val find_inductive   : env -> evar_map -> types -> pinductive * constr list
 val find_coinductive : env -> evar_map -> types -> pinductive * constr list
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index be772a6677..60140a31d9 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -45,13 +45,7 @@ let invert_tag cst tag reloc_tbl =
   with Find_at j -> (j+1)
              (* Argggg, ces constructeurs de ... qui commencent a 1*)
 
-let find_rectype_a env c =
-  let (t, l) =
-    let t = whd_betadeltaiota env c in
-    try destApp t with DestKO -> (t,[||]) in
-  match kind_of_term t with
-  | Ind ind -> (ind, l)
-  | _ -> raise Not_found
+let find_rectype_a env c = Inductiveops.find_mrectype_vect env Evd.empty c
 
 (* Instantiate inductives and parameters in constructor type *)
 
-- 
cgit v1.2.3


From ade2363e357db3ac3f258e645fe6bba988e7e7dd Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Thu, 19 Nov 2015 22:49:25 +0100
Subject: About building of substitutions from instances.

Redefining adjust_subst_to_rel_context from instantiate_context who
was hidden in inductiveops.ml, renamed the latter into
subst_of_rel_context_instance and moving them to Vars. The new name
highlights that the input is an instance (as for applist) and the
output a substitution (as for substl). This is a clearer unified
interface, centralizing the difficult de-Bruijn job in one place. It
saves a couple of List.rev.
---
 pretyping/cases.ml        |  8 ++++----
 pretyping/inductiveops.ml | 10 +---------
 pretyping/vnorm.ml        |  2 +-
 3 files changed, 6 insertions(+), 14 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index a5a7ace221..b894cb8ea4 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -837,10 +837,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0
 let substnl_predicate sigma = map_predicate (substnl sigma)
 
 (* This is parallel bindings *)
-let subst_predicate (args,copt) ccl tms =
+let subst_predicate (subst,copt) ccl tms =
   let sigma = match copt with
-    | None -> List.rev args
-    | Some c -> c::(List.rev args) in
+    | None -> subst
+    | Some c -> c::subst in
   substnl_predicate sigma 0 ccl tms
 
 let specialize_predicate_var (cur,typ,dep) tms ccl =
@@ -1018,7 +1018,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
   (* We prepare the substitution of X and x:I(X) *)
   let realargsi =
     if not (Int.equal nrealargs 0) then
-      adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
+      subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs)
     else
       [] in
   let copti = match depna with
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 632e00ed70..4c2ae61c30 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -354,14 +354,6 @@ let substnl_rel_context subst n sign =
 
 let substl_rel_context subst = substnl_rel_context subst 0
 
-let instantiate_context sign args =
-  let rec aux subst = function
-  | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args)
-  | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args)
-  | [], [] -> subst
-  | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family")
-  in aux [] (List.rev sign,args)
-
 let get_arity env ((ind,u),params) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let parsign =
@@ -379,7 +371,7 @@ let get_arity env ((ind,u),params) =
   let parsign = Vars.subst_instance_context u parsign in
   let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in
   let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in
-  let subst = instantiate_context parsign params in
+  let subst = subst_of_rel_context_instance parsign params in
   let arsign = Vars.subst_instance_context u arsign in
   (substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
 
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 60140a31d9..c59e085e5b 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -57,7 +57,7 @@ let type_constructor mind mib u typ params =
   if Int.equal ndecls 0 then ctyp
   else
     let _,ctyp = decompose_prod_n_assum ndecls ctyp in
-    substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
+    substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
       ctyp
 
 
-- 
cgit v1.2.3


From e7f7fc3e0582867975642fcaa7bd42140c61cd99 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 22 Nov 2015 13:21:31 +0100
Subject: Simplifying an instantiation function using
 subst_of_rel_context_instance.

---
 pretyping/inductiveops.ml | 24 +++++++++---------------
 1 file changed, 9 insertions(+), 15 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 4c2ae61c30..cc4ea5a4a2 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -303,21 +303,15 @@ let lift_constructor n cs = {
   cs_args = lift_rel_context n cs.cs_args;
   cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
 }
-(* Accept less parameters than in the signature *)
-
-let instantiate_params t args sign =
-  let rec inst s t = function
-    | ((_,None,_)::ctxt,a::args) ->
-	(match kind_of_term t with
-	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
-	   | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
-    | ((_,(Some b),_)::ctxt,args) ->
-	(match kind_of_term t with
-	   | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
-	   | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
-    | _, [] -> substl s t
-    | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")
-  in inst [] t (List.rev sign,args)
+
+(* Accept either all parameters or only recursively uniform ones *)
+let instantiate_params t params sign =
+  let nnonrecpar = rel_context_nhyps sign - List.length params in
+  (* Adjust the signature if recursively non-uniform parameters are not here *)
+  let _,sign = List.chop nnonrecpar sign in
+  let _,t = decompose_prod_n_assum (rel_context_length sign) t in
+  let subst = subst_of_rel_context_instance sign params in
+  substl subst t
 
 let get_constructor ((ind,u as indu),mib,mip,params) j =
   assert (j <= Array.length mip.mind_consnames);
-- 
cgit v1.2.3


From 6899d3aa567436784a08af4e179c2ef1fa504a02 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 21 Nov 2015 00:17:21 +0100
Subject: Moving extended_rel_vect/extended_rel_list to the kernel.

It will later be used to fix a bug and improve some code.

Interestingly, there were a redundant semantic equivalent to
extended_rel_list in the kernel called local_rels, and another private
copy of extended_rel_list in exactly the same file.
---
 pretyping/indrec.ml      | 32 ++++++++++++++++----------------
 pretyping/typeclasses.ml |  2 +-
 2 files changed, 17 insertions(+), 17 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 6dfc32bf1a..8ea9a5f66a 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -61,7 +61,7 @@ let check_privacy_block mib =
 
 let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
   let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in
-  let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in
+  let indf = make_ind_family(pind, Context.extended_rel_list 0 lnamespar) in
   let constrs = get_constructors env indf in
   let projs = get_projections env indf in
 
@@ -92,8 +92,8 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
-           if dep then Termops.extended_rel_vect 0 deparsign
-           else Termops.extended_rel_vect 1 arsign) in
+           if dep then Context.extended_rel_vect 0 deparsign
+           else Context.extended_rel_vect 1 arsign) in
       let p =
 	it_mkLambda_or_LetIn_name env'
 	  ((if dep then mkLambda_name env' else mkLambda)
@@ -165,7 +165,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	    let base = applist (lift i pk,realargs) in
             if depK then
 	      Reduction.beta_appvect
-                base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
+                base [|applist (mkRel (i+1), Context.extended_rel_list 0 sign)|]
             else
 	      base
       	| _ -> assert false
@@ -237,7 +237,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = List.skipn nparrec largs
-            and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
+            and arg = appvect (mkRel (i+1), Context.extended_rel_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
     in
@@ -323,7 +323,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 
             (* arity in the context of the fixpoint, i.e.
                P1..P_nrec f1..f_nbconstruct *)
-	    let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in
+	    let args = Context.extended_rel_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family((indi,u),args) in
 
 	    let arsign,_ = get_arity env indf in
@@ -337,15 +337,15 @@ let mis_make_indrec env sigma listdepkind mib u =
 
             (* constructors in context of the Cases expr, i.e.
                P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
-	    let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in
-	    let args'' = Termops.extended_rel_list ndepar lnonparrec in
+	    let args' = Context.extended_rel_list (dect+nrec) lnamesparrec in
+	    let args'' = Context.extended_rel_list ndepar lnonparrec in
             let indf' = make_ind_family((indi,u),args'@args'') in
 
 	    let branches =
 	      let constrs = get_constructors env indf' in
 	      let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
 	      let vecfi = Array.map
-		(fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
+		(fun f -> appvect (f, Context.extended_rel_vect ndepar lnonparrec))
 		fi
 	      in
 		Array.map3
@@ -366,9 +366,9 @@ let mis_make_indrec env sigma listdepkind mib u =
 	    let deparsign' = (Anonymous,None,depind')::arsign' in
 
 	    let pargs =
-	      let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec
-	      and nrar = if dep then Termops.extended_rel_list 0 deparsign'
-		else Termops.extended_rel_list 1 arsign'
+	      let nrpar = Context.extended_rel_list (2*ndepar) lnonparrec
+	      and nrar = if dep then Context.extended_rel_list 0 deparsign'
+		else Context.extended_rel_list 1 arsign'
 	      in nrpar@nrar
 
 	    in
@@ -411,8 +411,8 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let typtyi =
 	      let concl =
-		let pargs = if dep then Termops.extended_rel_vect 0 deparsign
-		  else Termops.extended_rel_vect 1 arsign
+		let pargs = if dep then Context.extended_rel_vect 0 deparsign
+		  else Context.extended_rel_vect 1 arsign
 		in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
 	      in it_mkProd_or_LetIn_name env
 		concl
@@ -439,7 +439,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 	    else
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
 	      let recarg = recargpar@recarg in
-	      let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in
+	      let vargs = Context.extended_rel_list (nrec+i+j) lnamesparrec in
 	      let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
@@ -453,7 +453,7 @@ let mis_make_indrec env sigma listdepkind mib u =
     in
     let rec put_arity env i = function
       | ((indi,u),_,_,dep,kinds)::rest ->
-	  let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in
+	  let indf = make_ind_family ((indi,u), Context.extended_rel_list i lnamesparrec) in
 	  let s = 
 	    Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) 
 	      evdref kinds 
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 2ef2896506..deb03f5160 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -287,7 +287,7 @@ let build_subclasses ~check env sigma glob pri =
       | None -> []
       | Some (rels, ((tc,u), args)) ->
 	let instapp = 
-	  Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) 
+	  Reductionops.whd_beta sigma (appvectc c (Context.extended_rel_vect 0 rels))
 	in
 	let projargs = Array.of_list (args @ [instapp]) in
 	let projs = List.map_filter 
-- 
cgit v1.2.3


From e8c47b652a0b53f8d3f7eaa877e81910c8de55d0 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sun, 22 Nov 2015 17:11:39 +0100
Subject: Unifying betazeta_applist and prod_applist into a clearer interface.

- prod_applist
- prod_applist_assum
- lambda_applist
- lambda_applist_assum

expect an instance matching the quantified context. They are now in
term.ml, with "list" being possibly "vect".

Names are a bit arbitrary. Better propositions are welcome. They are
put in term.ml in that reduction is after all not needed, because the
intent is not to do β or ι on the fly but rather to substitute a λΓ.c
or ∀Γ.c (seen as internalization of a Γ⊢c) into one step,
independently of the idea of reducing.

On the other side:

- beta_applist
- beta_appvect

are seen as optimizations of application doing reduction on the fly
only if possible. They are then kept as functions relevant for
reduction.ml.
---
 pretyping/inductiveops.ml | 2 +-
 pretyping/typing.ml       | 3 +--
 2 files changed, 2 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index cc4ea5a4a2..82168f9c4a 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -518,7 +518,7 @@ let type_case_branches_with_names env indspec p c =
   let (params,realargs) = List.chop nparams args in
   let lbrty = Inductive.build_branches_type ind specif params p in
   (* Build case type *)
-  let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
+  let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
   (* Adjust names *)
   if is_elim_predicate_explicitly_dependent env p (ind,params) then
     (set_pattern_names env (fst ind) lbrty, conclty)
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index fb5927dbf7..15abfefb15 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -112,8 +112,7 @@ let e_type_case_branches env evdref (ind,largs) pj c =
   let univ = e_is_correct_arity env evdref c pj ind specif params in
   let lc = build_branches_type ind specif params p in
   let n = (snd specif).Declarations.mind_nrealargs in
-  let ty =
-    whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
+  let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in
   (lc, ty, univ)
 
 let e_judge_of_case env evdref ci pj cj lfj =
-- 
cgit v1.2.3


From c6b75e1b693ab8c7af2efd1b93f04eab248e584c Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 11 Dec 2015 19:28:04 +0100
Subject: Optimize occur_evar_upto_types, avoiding repeateadly looking into the
 same evar.

---
 pretyping/evarsolve.ml | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index aeb2445d1c..fe26dcd282 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1286,10 +1286,16 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs =
       | l -> evd
 
 let occur_evar_upto_types sigma n c =
+  let seen = ref Evar.Set.empty in
   let rec occur_rec c = match kind_of_term c with
     | Evar (sp,_) when Evar.equal sp n -> raise Occur
-    | Evar e -> Option.iter occur_rec (existential_opt_value sigma e);
-		occur_rec (existential_type sigma e)
+    | Evar (sp,args as e) ->
+       if Evar.Set.mem sp !seen then
+         Array.iter occur_rec args
+       else (
+         seen := Evar.Set.add sp !seen;
+	 Option.iter occur_rec (existential_opt_value sigma e);
+	 occur_rec (existential_type sigma e))
     | _ -> iter_constr occur_rec c
   in
   try occur_rec c; false with Occur -> true
-- 
cgit v1.2.3


From a582737fc27da2c03c8c57c773fc4854c1e88d7a Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Tue, 15 Dec 2015 14:03:12 +0100
Subject: API: documenting context_chop and removing a duplicate.

---
 pretyping/indrec.ml | 13 +------------
 1 file changed, 1 insertion(+), 12 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 8ea9a5f66a..3f21842e39 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -277,24 +277,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   in
   process_constr env 0 f (List.rev cstr.cs_args, recargs)
 
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
-   variables *)
-let context_chop k ctx =
-  let rec chop_aux acc = function
-    | (0, l2) -> (List.rev acc, l2)
-    | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
-    | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
-    | (_, []) -> failwith "context_chop"
-  in chop_aux [] (k,ctx)
-
 (* Main function *)
 let mis_make_indrec env sigma listdepkind mib u =
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
   let evdref = ref sigma in
   let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
+    Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
   let nrec = List.length listdepkind in
   let depPvec =
     Array.make mib.mind_ntypes (None : (bool * constr) option) in
-- 
cgit v1.2.3


From a4a0a47dce78a7d580e172331e7e1ee2881dc689 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Tue, 15 Dec 2015 14:10:17 +0100
Subject: Fixing e7f7fc3e058 (wrong chop on contexts). This fixes test-suite.

---
 pretyping/inductiveops.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 82168f9c4a..f429c51eb8 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -308,7 +308,7 @@ let lift_constructor n cs = {
 let instantiate_params t params sign =
   let nnonrecpar = rel_context_nhyps sign - List.length params in
   (* Adjust the signature if recursively non-uniform parameters are not here *)
-  let _,sign = List.chop nnonrecpar sign in
+  let _,sign = context_chop nnonrecpar sign in
   let _,t = decompose_prod_n_assum (rel_context_length sign) t in
   let subst = subst_of_rel_context_instance sign params in
   substl subst t
-- 
cgit v1.2.3


From 087c61eb7fcf17d4ef6ac5b40765e567b9cbcdc8 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Tue, 15 Dec 2015 14:35:29 +0100
Subject: Fixing unexpected length of context in a typing function, detected by
 cleaning done in e8c47b652a0.

It had no serious consequences except having whd-reduction blocked on
a let-in when typing a return clause with let-ins in the arity (a
priori resulting in return types of the form e.g. "(let x:=t in fun y
=> T) u" instead of T[x:=t;y:=u], if I'm not mistaking).

This fixes 3210.v in test-suite.
---
 pretyping/typing.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 15abfefb15..2f9803b62f 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -111,7 +111,7 @@ let e_type_case_branches env evdref (ind,largs) pj c =
   let p = pj.uj_val in
   let univ = e_is_correct_arity env evdref c pj ind specif params in
   let lc = build_branches_type ind specif params p in
-  let n = (snd specif).Declarations.mind_nrealargs in
+  let n = (snd specif).Declarations.mind_nrealdecls in
   let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in
   (lc, ty, univ)
 
-- 
cgit v1.2.3


From 39b13903e7a6824f4405f61bb4b41a30cfbd0b3c Mon Sep 17 00:00:00 2001
From: Matej Kosik
Date: Wed, 9 Dec 2015 12:30:32 +0100
Subject: CLEANUP: in the Reduction module

---
 pretyping/reductionops.ml | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index d5a93230f3..03e7f26420 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1264,8 +1264,8 @@ let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
   with Reduction.NotConvertible -> false
     | e when is_anomaly e -> report_anomaly e
 
-let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma
-let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma
+let is_trans_conv reds env sigma = test_trans_conversion Reduction.conv_universes reds env sigma
+let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma
 let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq
 
 let is_conv = is_trans_conv full_transparent_state
@@ -1274,8 +1274,8 @@ let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv
 
 let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = 
   let f = match pb with
-    | Reduction.CONV -> Reduction.trans_conv_universes
-    | Reduction.CUMUL -> Reduction.trans_conv_leq_universes 
+    | Reduction.CONV -> Reduction.conv_universes
+    | Reduction.CUMUL -> Reduction.conv_leq_universes 
   in
     try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
     with Reduction.NotConvertible -> false
-- 
cgit v1.2.3


From 57a90691e4a64853113ab38487a5406a32c8c117 Mon Sep 17 00:00:00 2001
From: Matej Kosik
Date: Wed, 9 Dec 2015 15:22:08 +0100
Subject: CLEANUP: in the Reductionops module

---
 pretyping/evarconv.ml      |  2 +-
 pretyping/reductionops.ml  | 12 +++++-------
 pretyping/reductionops.mli | 10 +++-------
 3 files changed, 9 insertions(+), 15 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 60d92f4beb..955bfa1656 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -1099,7 +1099,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
       | Some evd -> Success evd
       | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
   | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 ->
-      let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in
+      let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in
       Success (solve_refl ~can_drop:true f env evd
                  (position_problem true pbty) evk1 args1 args2)
   | Evar ev1, Evar ev2 ->
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 03e7f26420..97f35fbd39 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1264,13 +1264,11 @@ let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
   with Reduction.NotConvertible -> false
     | e when is_anomaly e -> report_anomaly e
 
-let is_trans_conv reds env sigma = test_trans_conversion Reduction.conv_universes reds env sigma
-let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma
-let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq
-
-let is_conv = is_trans_conv full_transparent_state
-let is_conv_leq = is_trans_conv_leq full_transparent_state
-let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq
+let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_universes reds env sigma
+let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma
+let is_fconv ?(reds=full_transparent_state) = function
+  | Reduction.CONV -> is_conv ~reds
+  | Reduction.CUMUL -> is_conv_leq ~reds
 
 let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = 
   let f = match pb with
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index d5a844847c..43c98bbd47 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -251,13 +251,9 @@ type conversion_test = constraints -> constraints
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
-val is_conv : env ->  evar_map -> constr -> constr -> bool
-val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
-val is_fconv : conv_pb -> env ->  evar_map -> constr -> constr -> bool
-
-val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool
-val is_trans_conv_leq : transparent_state -> env ->  evar_map -> constr -> constr -> bool
-val is_trans_fconv : conv_pb -> transparent_state -> env ->  evar_map -> constr -> constr -> bool
+val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv_leq : ?reds:transparent_state -> env ->  evar_map -> constr -> constr -> bool
+val is_fconv : ?reds:transparent_state -> conv_pb -> env ->  evar_map -> constr -> constr -> bool
 
 (** [check_conv] Checks universe constraints only.
     pb defaults to CUMUL and ts to a full transparent state.
-- 
cgit v1.2.3


From 672f8ee0c96584735294641bb4b8760e25197b80 Mon Sep 17 00:00:00 2001
From: Matej Kosik
Date: Mon, 14 Dec 2015 12:52:49 +0100
Subject: CLEANUP: in the Reduction module

---
 pretyping/reductionops.ml | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 97f35fbd39..3f02e4bfb1 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1256,26 +1256,26 @@ let report_anomaly _ =
   let e = Errors.push e in
   iraise e
 
-let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
+let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y =
   try
     let evars ev = safe_evar_value sigma ev in
-    let _ = f ~evars reds env (Evd.universes sigma) x y in
+    let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in
     true
   with Reduction.NotConvertible -> false
     | e when is_anomaly e -> report_anomaly e
 
-let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_universes reds env sigma
-let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma
+let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma
+let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma
 let is_fconv ?(reds=full_transparent_state) = function
   | Reduction.CONV -> is_conv ~reds
   | Reduction.CUMUL -> is_conv_leq ~reds
 
 let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = 
   let f = match pb with
-    | Reduction.CONV -> Reduction.conv_universes
-    | Reduction.CUMUL -> Reduction.conv_leq_universes 
+    | Reduction.CONV -> Reduction.conv
+    | Reduction.CUMUL -> Reduction.conv_leq
   in
-    try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
+    try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true
     with Reduction.NotConvertible -> false
     | Univ.UniverseInconsistency _ -> false
     | e when is_anomaly e -> report_anomaly e
-- 
cgit v1.2.3


From 840cefca77a48ad68641539cd26d8d2e8c9dc031 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 17 Dec 2015 20:32:09 +0100
Subject: (Partial) fix for bug #4453: raise an error instead of an anomaly.

---
 pretyping/typing.ml | 18 +++++++++++++++---
 1 file changed, 15 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index fb5927dbf7..db980e455a 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -144,8 +144,13 @@ let e_judge_of_cast env evdref cj k tj =
   { uj_val = mkCast (cj.uj_val, k, expected_type);
     uj_type = expected_type }
 
-(* The typing machine without information, without universes but with
-   existential variables. *)
+let enrich_env env evdref =
+  let penv = Environ.pre_env env in
+  let penv' = Pre_env.({ penv with env_stratification =
+    { penv.env_stratification with env_universes = Evd.universes !evdref } }) in
+  Environ.env_of_pre_env penv'
+			  
+(* The typing machine with universes and existential variables. *)
 
 (* cstr must be in n.f. w.r.t. evars and execute returns a judgement
    where both the term and type are in n.f. *)
@@ -264,6 +269,7 @@ and execute_recdef env evdref (names,lar,vdef) =
 and execute_array env evdref = Array.map (execute env evdref)
 
 let check env evdref c t =
+  let env = enrich_env env evdref in
   let j = execute env evdref c in
   if not (Evarconv.e_cumul env evdref j.uj_type t) then
     error_actual_type env j (nf_evar !evdref t)
@@ -271,12 +277,15 @@ let check env evdref c t =
 (* Type of a constr *)
 
 let unsafe_type_of env evd c =
-  let j = execute env (ref evd) c in
+  let evdref = ref evd in
+  let env = enrich_env env evdref in
+  let j = execute env evdref c in
     j.uj_type
 
 (* Sort of a type *)
 
 let sort_of env evdref c =
+  let env = enrich_env env evdref in
   let j = execute env evdref c in
   let a = e_type_judgment env evdref j in
   a.utj_type
@@ -285,6 +294,7 @@ let sort_of env evdref c =
 
 let type_of ?(refresh=false) env evd c =
   let evdref = ref evd in
+  let env = enrich_env env evdref in
   let j = execute env evdref c in
   (* side-effect on evdref *)
     if refresh then
@@ -292,6 +302,7 @@ let type_of ?(refresh=false) env evd c =
     else !evdref, j.uj_type
 
 let e_type_of ?(refresh=false) env evdref c =
+  let env = enrich_env env evdref in
   let j = execute env evdref c in
   (* side-effect on evdref *)
     if refresh then
@@ -301,6 +312,7 @@ let e_type_of ?(refresh=false) env evdref c =
     else j.uj_type
 
 let solve_evars env evdref c =
+  let env = enrich_env env evdref in
   let c = (execute env evdref c).uj_val in
   (* side-effect on evdref *)
   nf_evar !evdref c
-- 
cgit v1.2.3


From b2beb9087628de23679a831e6273b91816f1ed27 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Thu, 17 Dec 2015 19:24:17 +0100
Subject: Using dynamic values in tactic evaluation.

---
 pretyping/pretyping.ml  | 2 +-
 pretyping/pretyping.mli | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ce6d189855..f5b89e7895 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -47,7 +47,7 @@ open Misctypes
 type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
 type var_map = constr_under_binders Id.Map.t
 type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Genarg.Val.t Id.Map.t
 type ltac_var_map = {
   ltac_constrs : var_map;
   ltac_uconstrs : uconstr_var_map;
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index f8587d01cd..8b76816ab2 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
 
 type var_map = Pattern.constr_under_binders Id.Map.t
 type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Genarg.Val.t Id.Map.t
 
 type ltac_var_map = {
   ltac_constrs : var_map;
@@ -152,5 +152,5 @@ val interp_sort : evar_map -> glob_sort -> evar_map * sorts
 val interp_elimination_sort : glob_sort -> sorts_family
 
 val genarg_interp_hook :
-  (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t ->
+  (types -> env -> evar_map -> unbound_ltac_var_map ->
     Genarg.glob_generic_argument -> constr * evar_map) Hook.t
-- 
cgit v1.2.3


From b2eaecf0e748e3c286e1ef337f72cee6d3475162 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Tue, 29 Dec 2015 02:48:45 +0100
Subject: Fixing bug #4462: unshelve: Anomaly: Uncaught exception Not_found.

The rewrite tactic was causing an evar leak because of the use of the
Evd.remove primitive. This function did not modify the future goals of
the evarmap to remove the considered evar and thus maintained dangling
evars in there, causing the anomaly.
---
 pretyping/evd.ml | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index c9b9f34414..8edc7a17c6 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -658,7 +658,12 @@ let add d e i = match i.evar_body with
 let remove d e =
   let undf_evars = EvMap.remove e d.undf_evars in
   let defn_evars = EvMap.remove e d.defn_evars in
-  { d with undf_evars; defn_evars; }
+  let principal_future_goal = match d.principal_future_goal with
+  | None -> None
+  | Some e' -> if Evar.equal e e' then None else d.principal_future_goal
+  in
+  let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in
+  { d with undf_evars; defn_evars; principal_future_goal; future_goals }
 
 let find d e =
   try EvMap.find e d.undf_evars
-- 
cgit v1.2.3


From 1a157442dff4bfa127af467c49280e79889acde7 Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Sat, 26 Dec 2015 10:07:19 +0100
Subject: Do not compose List.length with List.filter.

---
 pretyping/recordops.ml   | 2 +-
 pretyping/typeclasses.ml | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 7fde7b7ac4..af48654015 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -299,7 +299,7 @@ let check_and_decompose_canonical_structure ref =
     | Construct ((indsp,1),u) -> indsp
     | _ -> error_not_structure ref in
   let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
-  let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in
+  let ntrue_projs = List.count snd s.s_PROJKIND in
   if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
     error_not_structure ref;
   (sp,indsp)
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index deb03f5160..c44fbc0ba8 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -436,7 +436,7 @@ let instance_constructor (cl,u) args =
   | None -> true
   | Some _ -> false
   in
-  let lenpars = List.length (List.filter filter (snd cl.cl_context)) in
+  let lenpars = List.count filter (snd cl.cl_context) in
   let pars = fst (List.chop lenpars args) in
     match cl.cl_impl with
       | IndRef ind -> 
-- 
cgit v1.2.3


From 5129c5b02bcab1426636d18583ec7a4a46195f0a Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Sat, 2 Jan 2016 16:55:03 +0100
Subject: Reduce dependencies of interface files.

---
 pretyping/nativenorm.mli | 1 -
 pretyping/patternops.mli | 1 -
 pretyping/vnorm.mli      | 1 -
 3 files changed, 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index 0352038385..286cb2e079 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -8,7 +8,6 @@
 open Term
 open Environ
 open Evd
-open Nativelambda
 
 (** This module implements normalization by evaluation to OCaml code *)
 
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 0148280287..34191db344 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -6,7 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Context
 open Term
 open Globnames
 open Glob_term
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 9421b2d859..b75fe7c928 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -8,7 +8,6 @@
 
 open Term
 open Environ
-open Evd
 
 (** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
-- 
cgit v1.2.3


From d531f81802c0e152e83868f467b46721e65445a9 Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Sat, 2 Jan 2016 16:55:35 +0100
Subject: Remove duplicate declarations.

---
 pretyping/reductionops.mli | 1 -
 1 file changed, 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 43c98bbd47..30c7ded243 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -222,7 +222,6 @@ val splay_prod_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_lam_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_prod_assum :
   env ->  evar_map -> constr -> rel_context * constr
-val is_sort : env -> evar_map -> types -> bool
 
 type 'a miota_args = {
   mP      : constr;     (** the result type *)
-- 
cgit v1.2.3


From 80bbdf335be5657f5ab33b4aa02e21420d341de2 Mon Sep 17 00:00:00 2001
From: Guillaume Melquiond
Date: Sat, 2 Jan 2016 17:11:03 +0100
Subject: Remove some unused functions.

Note: they do not even seem to have a debugging purpose, so better remove
them before they bitrot.
---
 pretyping/evarsolve.ml | 15 ---------------
 pretyping/pretyping.ml | 14 --------------
 pretyping/tacred.ml    |  6 ------
 3 files changed, 35 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index fe26dcd282..69e8e9d988 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1007,21 +1007,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
  * Note: argument f is the function used to instantiate evars.
  *)
 
-let are_canonical_instances args1 args2 env =
-  let n1 = Array.length args1 in
-  let n2 = Array.length args2 in
-  let rec aux n = function
-    | (id,_,c)::sign
-        when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
-        aux (n+1) sign
-    | [] ->
-        let rec aux2 n =
-          Int.equal n n1 ||
-          (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
-        in aux2 n
-    | _ -> false in
-  Int.equal n1 n2 && aux 0 (named_context env)
-
 let filter_compatible_candidates conv_algo env evd evi args rhs c =
   let c' = instantiate_evar_array evi c args in
   match conv_algo env evd Reduction.CONV rhs c' with
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index f5b89e7895..7d54969171 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -444,26 +444,12 @@ let new_type_evar env evdref loc =
       univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
   in e
 
-let get_projection env cst =
-  let cb = lookup_constant cst env in
-    match cb.Declarations.const_proj with
-    | Some {Declarations.proj_ind = mind; proj_npars = n;
-	    proj_arg = m; proj_type = ty} -> 
-      (cst,mind,n,m,ty)
-    | None -> raise Not_found
-
 let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
 
 (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
 (* in environment [env], with existential variables [evdref] and *)
 (* the type constraint tycon *)
 
-let is_GHole = function
-  | GHole _ -> true
-  | _ -> false
-
-let evars = ref Id.Map.empty
-
 let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t =
   let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
   let pretype_type = pretype_type k0 resolve_tc in
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 48911a5a9f..31e75e5508 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -940,8 +940,6 @@ let matches_head env sigma c t =
     | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p))
     | _ -> raise Constr_matching.PatternMatchingFailure
 
-let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false
-
 (** FIXME: Specific function to handle projections: it ignores what happens on the
     parameters. This is a temporary fix while rewrite etc... are not up to equivalence
     of the projection and its eta expanded form.
@@ -1055,10 +1053,6 @@ let unfold env sigma name =
   else
     error (string_of_evaluable_ref env name^" is opaque.")
 
-let is_projection env = function
-  | EvalVarRef _ -> false
-  | EvalConstRef c -> Environ.is_projection c env
-
 (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
  * Unfolds the constant name in a term c following a list of occurrences occl.
  * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences.
-- 
cgit v1.2.3


From 9d991d36c07efbb6428e277573bd43f6d56788fc Mon Sep 17 00:00:00 2001
From: Matej Kosik
Date: Fri, 8 Jan 2016 10:00:21 +0100
Subject: CLEANUP: kernel/context.ml{,i}

The structure of the Context module was refined in such a way that:
- Types and functions related to rel-context declarations were put into the Context.Rel.Declaration module.
- Types and functions related to rel-context were put into the Context.Rel module.
- Types and functions related to named-context declarations were put into the Context.Named.Declaration module.
- Types and functions related to named-context were put into the Context.Named module.
- Types and functions related to named-list-context declarations were put into Context.NamedList.Declaration module.
- Types and functions related to named-list-context were put into Context.NamedList module.

Some missing comments were added to the *.mli file.

The output of ocamldoc was checked whether it looks in a reasonable way.

"TODO: cleanup" was removed

The order in which are exported functions listed in the *.mli file was changed.
(as in a mature modules, this order usually is not random)

The order of exported functions in Context.{Rel,Named} modules is now consistent.
(as there is no special reason why that order should be different)

The order in which are functions defined in the *.ml file is the same as the order in which they are listed in the *.mli file.
(as there is no special reason to define them in a different order)

The name of the original fold_{rel,named}_context{,_reverse} functions was changed to better indicate what those functions do.
(Now they are called Context.{Rel,Named}.fold_{inside,outside})

The original comments originally attached to the fold_{rel,named}_context{,_reverse} did not full make sense so they were updated.

Thrown exceptions are now documented.

Naming of formal parameters was made more consistent across different functions.

Comments of similar functions in different modules are now consistent.

Comments from *.mli files were copied to *.ml file.
(We need that information in *.mli files because that is were ocamldoc needs it.
 It is nice to have it also in *.ml files because when we are using Merlin and jump to the definion of the function,
 we can see the comments also there and do not need to open a different file if we want to see it.)

When we invoke ocamldoc, we instruct it to generate UTF-8 HTML instead of (default) ISO-8859-1.
(UTF-8 characters are used in our ocamldoc markup)

"open Context" was removed from all *.mli and *.ml files.
(Originally, it was OK to do that. Now it is not.)

An entry to dev/doc/changes.txt file was added that describes how the names of types and functions have changed.
---
 pretyping/cases.ml               | 27 +++++++++++++--------------
 pretyping/cases.mli              |  9 ++++-----
 pretyping/constr_matching.ml     |  5 ++---
 pretyping/detyping.ml            |  5 ++---
 pretyping/detyping.mli           |  3 +--
 pretyping/evarsolve.ml           |  3 +--
 pretyping/evarutil.ml            | 11 +++++------
 pretyping/evarutil.mli           |  7 +++----
 pretyping/find_subterm.mli       |  5 ++---
 pretyping/indrec.ml              | 39 +++++++++++++++++++--------------------
 pretyping/inductiveops.ml        | 35 +++++++++++++++++------------------
 pretyping/inductiveops.mli       | 19 +++++++++----------
 pretyping/patternops.mli         |  1 -
 pretyping/pretyping.ml           | 19 +++++++++----------
 pretyping/reductionops.ml        | 15 +++++++--------
 pretyping/reductionops.mli       |  7 +++----
 pretyping/retyping.mli           |  3 +--
 pretyping/typeclasses.ml         | 11 +++++------
 pretyping/typeclasses.mli        |  7 +++----
 pretyping/typeclasses_errors.ml  |  3 +--
 pretyping/typeclasses_errors.mli |  5 ++---
 pretyping/unification.ml         |  4 ++--
 pretyping/unification.mli        |  2 +-
 pretyping/vnorm.ml               |  2 +-
 24 files changed, 113 insertions(+), 134 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index b894cb8ea4..adcaa64412 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -13,7 +13,6 @@ open Names
 open Nameops
 open Term
 open Vars
-open Context
 open Termops
 open Namegen
 open Declarations
@@ -131,7 +130,7 @@ type tomatch_status =
   | Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
   | Alias of (bool*(Name.t * constr * (constr * types)))
   | NonDepAlias
-  | Abstract of int * rel_declaration
+  | Abstract of int * Context.Rel.Declaration.t
 
 type tomatch_stack = tomatch_status list
 
@@ -602,7 +601,7 @@ let relocate_index_tomatch n1 n2 =
       NonDepAlias :: genrec depth rest
   | Abstract (i,d) :: rest ->
       let i = relocate_rel n1 n2 depth i in
-      Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d)
+      Abstract (i, Context.Rel.Declaration.map (relocate_index n1 n2 depth) d)
       :: genrec (depth+1) rest in
   genrec 0
 
@@ -635,7 +634,7 @@ let replace_tomatch n c =
   | NonDepAlias  :: rest ->
       NonDepAlias :: replrec depth rest
   | Abstract (i,d) :: rest ->
-      Abstract (i,map_rel_declaration (replace_term n c depth) d)
+      Abstract (i, Context.Rel.Declaration.map (replace_term n c depth) d)
       :: replrec (depth+1) rest in
   replrec 0
 
@@ -660,7 +659,7 @@ let rec liftn_tomatch_stack n depth = function
       NonDepAlias :: liftn_tomatch_stack n depth rest
   | Abstract (i,d)::rest ->
       let i = if i<depth then i else i+n in
-      Abstract (i,map_rel_declaration (liftn n depth) d)
+      Abstract (i, Context.Rel.Declaration.map (liftn n depth) d)
       ::(liftn_tomatch_stack n (depth+1) rest)
 
 let lift_tomatch_stack n = liftn_tomatch_stack n 1
@@ -921,7 +920,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
   let tms = List.fold_right2 (fun par arg tomatch ->
     match kind_of_term par with
     | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch
-    | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign)
+    | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign)
        (lift_tomatch_stack n tms) in
   (* Pred is already dependent in the current term to match (if      *)
   (* (na<>Anonymous) and its realargs; we just need to adjust it to  *)
@@ -1118,7 +1117,7 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
   let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
   | [], _ -> brs,tomatch,pred,[]
   | n::deps, Abstract (i,d) :: tomatch ->
-      let d = map_rel_declaration (nf_evar evd) d in
+      let d = Context.Rel.Declaration.map (nf_evar evd) d in
       let is_d = match d with (_, None, _) -> false | _ -> true in
       if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck
                  && Array.exists (is_dependent_branch k) brs then
@@ -1187,7 +1186,7 @@ let group_equations pb ind current cstrs mat =
 let rec generalize_problem names pb = function
   | [] -> pb, []
   | i::l ->
-      let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let (na,b,t as d) = Context.Rel.Declaration.map (lift i) (Environ.lookup_rel i pb.env) in
       let pb',deps = generalize_problem names pb l in
       begin match (na, b) with
       | Anonymous, Some _ -> pb', deps
@@ -1230,7 +1229,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
   (* We adjust the terms to match in the context they will be once the *)
   (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
   let typs' =
-    List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
+    List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 typs in
 
   let extenv = push_rel_context typs pb.env in
 
@@ -1560,8 +1559,8 @@ let matx_of_eqns env eqns =
 *)
 
 let adjust_to_extended_env_and_remove_deps env extenv subst t =
-  let n = rel_context_length (rel_context env) in
-  let n' = rel_context_length (rel_context extenv) in
+  let n = Context.Rel.length (rel_context env) in
+  let n' = Context.Rel.length (rel_context extenv) in
   (* We first remove the bindings that are dependently typed (they are
      difficult to manage and it is not sure these are so useful in practice);
      Notes:
@@ -1673,8 +1672,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
     | None ->
 	(* This is the situation we are building a return predicate and
            we are in an impossible branch *)
-	let n = rel_context_length (rel_context env) in
-	let n' = rel_context_length (rel_context tycon_env) in
+	let n = Context.Rel.length (rel_context env) in
+	let n' = Context.Rel.length (rel_context tycon_env) in
 	let impossible_case_type, u =
 	  e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in
 	(lift (n'-n) impossible_case_type, mkSort u)
@@ -1744,7 +1743,7 @@ let build_inversion_problem loc env sigma tms t =
   let n = List.length sign in
 
   let decls =
-    List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
+    List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 sign in
 
   let pb_env = push_rel_context sign env in
   let decls =
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index c599766ab7..4ec71956b4 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Evd
 open Environ
 open Inductiveops
@@ -45,11 +44,11 @@ val compile_cases :
 val constr_of_pat : 
            Environ.env ->
            Evd.evar_map ref ->
-           rel_declaration list ->
+           Context.Rel.Declaration.t list ->
            Glob_term.cases_pattern ->
            Names.Id.t list ->
            Glob_term.cases_pattern *
-           (rel_declaration list * Term.constr *
+           (Context.Rel.Declaration.t list * Term.constr *
             (Term.types * Term.constr list) * Glob_term.cases_pattern) *
            Names.Id.t list
 
@@ -83,7 +82,7 @@ type tomatch_status =
   | Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
   | Alias of (bool * (Name.t * constr * (constr * types)))
   | NonDepAlias
-  | Abstract of int * rel_declaration
+  | Abstract of int * Context.Rel.Declaration.t
 
 type tomatch_stack = tomatch_status list
 
@@ -117,7 +116,7 @@ val prepare_predicate :            Loc.t ->
            Environ.env ->
            Evd.evar_map ->
            (Term.types * tomatch_type) list ->
-           Context.rel_context list ->
+           Context.Rel.t list ->
            Constr.constr option ->
            'a option -> (Evd.evar_map * Names.name list * Term.constr) list
 
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 5e99521a12..0b0bd8304e 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -17,7 +17,6 @@ open Termops
 open Reductionops
 open Term
 open Vars
-open Context
 open Pattern
 open Patternops
 open Misctypes
@@ -269,8 +268,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
 	  let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in
 	  let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in
-	  let n = rel_context_length ctx_b2 in
-          let n' = rel_context_length ctx_b2' in
+	  let n = Context.Rel.length ctx_b2 in
+          let n' = Context.Rel.length ctx_b2' in
 	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
             let f l (na,_,t) = (Anonymous,na,t)::l in
 	    let ctx_br = List.fold_left f ctx ctx_b2 in
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index dab82fa22b..4ca066feb0 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -12,7 +12,6 @@ open Util
 open Names
 open Term
 open Vars
-open Context
 open Inductiveops
 open Environ
 open Glob_term
@@ -199,7 +198,7 @@ let computable p k =
        engendrera un prédicat non dépendant) *)
 
   let sign,ccl = decompose_lam_assum p in
-  Int.equal (rel_context_length sign) (k + 1)
+  Int.equal (Context.Rel.length sign) (k + 1)
   &&
   noccur_between 1 (k+1) ccl
 
@@ -315,7 +314,7 @@ let is_nondep_branch c l =
   try
     (* FIXME: do better using tags from l *)
     let sign,ccl = decompose_lam_n_decls (List.length l) c in
-    noccur_between 1 (rel_context_length sign) ccl
+    noccur_between 1 (Context.Rel.length sign) ccl
   with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
     false
 
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index eb158686aa..f8f8093c0f 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Environ
 open Glob_term
 open Termops
@@ -46,7 +45,7 @@ val detype_case :
 val detype_sort : evar_map -> sorts -> glob_sort
 
 val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> 
-  evar_map -> rel_context -> glob_decl list
+  evar_map -> Context.Rel.t -> glob_decl list
 
 val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr
 
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index fe26dcd282..c6c397135a 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -11,7 +11,6 @@ open Errors
 open Names
 open Term
 open Vars
-open Context
 open Environ
 open Termops
 open Evd
@@ -501,7 +500,7 @@ let solve_pattern_eqn env l c =
     match kind_of_term a with
       (* Rem: if [a] links to a let-in, do as if it were an assumption *)
       | Rel n ->
-          let d = map_rel_declaration (lift n) (lookup_rel n env) in
+          let d = Context.Rel.Declaration.map (lift n) (lookup_rel n env) in
           mkLambda_or_LetIn d c'
       | Var id ->
           let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 3c3afac54e..f001d6e3e9 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -12,7 +12,6 @@ open Pp
 open Names
 open Term
 open Vars
-open Context
 open Termops
 open Namegen
 open Pre_env
@@ -78,12 +77,12 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} =
 
 let env_nf_evar sigma env =
   process_rel_context
-    (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
+    (fun d e -> push_rel (Context.Rel.Declaration.map (nf_evar sigma) d) e) env
 
 let env_nf_betaiotaevar sigma env =
   process_rel_context
     (fun d e ->
-      push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
+      push_rel (Context.Rel.Declaration.map (Reductionops.nf_betaiota sigma) d) e) env
 
 let nf_evars_universes evm =
   Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) 
@@ -106,10 +105,10 @@ let nf_evar_map_universes evm =
 	Evd.raw_map (fun _ -> map_evar_info f) evm, f
 
 let nf_named_context_evar sigma ctx =
-  Context.map_named_context (nf_evar sigma) ctx
+  Context.Named.map (nf_evar sigma) ctx
 
 let nf_rel_context_evar sigma ctx =
-  Context.map_rel_context (nf_evar sigma) ctx
+  Context.Rel.map (nf_evar sigma) ctx
 
 let nf_env_evar sigma env =
   let nc' = nf_named_context_evar sigma (Environ.named_context env) in
@@ -303,7 +302,7 @@ let push_rel_context_to_named_context env typ =
   (* with vars of the rel context *)
   (* We do keep the instances corresponding to local definition (see above) *)
   let (subst, vsubst, _, env) =
-    Context.fold_rel_context
+    Context.Rel.fold_outside
       (fun (na,c,t) (subst, vsubst, avoid, env) ->
         let id =
           (* ppedrot: we want to infer nicer names for the refine tactic, but
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 96648bb111..867917c9cf 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Evd
 open Environ
 
@@ -129,7 +128,7 @@ val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.M
     [nf_evar]. *)
 
 val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
-val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t
+val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t
 val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
 
 (** [occur_evar_upto sigma k c] returns [true] if [k] appears in
@@ -170,8 +169,8 @@ val jv_nf_evar :
 val tj_nf_evar :
    evar_map -> unsafe_type_judgment -> unsafe_type_judgment
 
-val nf_named_context_evar : evar_map -> named_context -> named_context
-val nf_rel_context_evar : evar_map -> rel_context -> rel_context
+val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t
+val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t
 val nf_env_evar : evar_map -> env -> env
 
 val nf_evar_info : evar_map -> evar_info -> evar_info
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 47d9654e57..1366c34ce2 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -7,7 +7,6 @@
 (************************************************************************)
 
 open Locus
-open Context
 open Term
 open Evd
 open Pretype_errors
@@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first ->
 val replace_term_occ_decl_modulo :
   (occurrences * hyp_location_flag) or_like_first ->
   'a testing_function -> (unit -> constr) ->
-  named_declaration -> named_declaration
+  Context.Named.Declaration.t -> Context.Named.Declaration.t
 
 (** [subst_closed_term_occ occl c d] replaces occurrences of
     closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
@@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first ->
     closed [c] at positions [occl] by [Rel 1] in [decl]. *)
 val subst_closed_term_occ_decl : env -> evar_map ->
   (occurrences * hyp_location_flag) or_like_first ->
-  constr -> named_declaration -> named_declaration * evar_map
+  constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map
 
 (** Miscellaneous *)
 val error_invalid_occurrence : int list -> 'a
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 3f21842e39..40175dac91 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -19,7 +19,6 @@ open Globnames
 open Nameops
 open Term
 open Vars
-open Context
 open Namegen
 open Declarations
 open Declareops
@@ -61,7 +60,7 @@ let check_privacy_block mib =
 
 let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
   let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in
-  let indf = make_ind_family(pind, Context.extended_rel_list 0 lnamespar) in
+  let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in
   let constrs = get_constructors env indf in
   let projs = get_projections env indf in
 
@@ -92,8 +91,8 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
-           if dep then Context.extended_rel_vect 0 deparsign
-           else Context.extended_rel_vect 1 arsign) in
+           if dep then Context.Rel.to_extended_vect 0 deparsign
+           else Context.Rel.to_extended_vect 1 arsign) in
       let p =
 	it_mkLambda_or_LetIn_name env'
 	  ((if dep then mkLambda_name env' else mkLambda)
@@ -165,7 +164,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	    let base = applist (lift i pk,realargs) in
             if depK then
 	      Reduction.beta_appvect
-                base [|applist (mkRel (i+1), Context.extended_rel_list 0 sign)|]
+                base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|]
             else
 	      base
       	| _ -> assert false
@@ -237,7 +236,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = List.skipn nparrec largs
-            and arg = appvect (mkRel (i+1), Context.extended_rel_vect 0 hyps) in
+            and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
     in
@@ -312,29 +311,29 @@ let mis_make_indrec env sigma listdepkind mib u =
 
             (* arity in the context of the fixpoint, i.e.
                P1..P_nrec f1..f_nbconstruct *)
-	    let args = Context.extended_rel_list (nrec+nbconstruct) lnamesparrec in
+	    let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family((indi,u),args) in
 
 	    let arsign,_ = get_arity env indf in
 	    let depind = build_dependent_inductive env indf in
 	    let deparsign = (Anonymous,None,depind)::arsign in
 
-	    let nonrecpar = rel_context_length lnonparrec in
-	    let larsign = rel_context_length deparsign in
+	    let nonrecpar = Context.Rel.length lnonparrec in
+	    let larsign = Context.Rel.length deparsign in
 	    let ndepar = larsign - nonrecpar in
 	    let dect = larsign+nrec+nbconstruct in
 
             (* constructors in context of the Cases expr, i.e.
                P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
-	    let args' = Context.extended_rel_list (dect+nrec) lnamesparrec in
-	    let args'' = Context.extended_rel_list ndepar lnonparrec in
+	    let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in
+	    let args'' = Context.Rel.to_extended_list ndepar lnonparrec in
             let indf' = make_ind_family((indi,u),args'@args'') in
 
 	    let branches =
 	      let constrs = get_constructors env indf' in
 	      let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
 	      let vecfi = Array.map
-		(fun f -> appvect (f, Context.extended_rel_vect ndepar lnonparrec))
+		(fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec))
 		fi
 	      in
 		Array.map3
@@ -355,9 +354,9 @@ let mis_make_indrec env sigma listdepkind mib u =
 	    let deparsign' = (Anonymous,None,depind')::arsign' in
 
 	    let pargs =
-	      let nrpar = Context.extended_rel_list (2*ndepar) lnonparrec
-	      and nrar = if dep then Context.extended_rel_list 0 deparsign'
-		else Context.extended_rel_list 1 arsign'
+	      let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec
+	      and nrar = if dep then Context.Rel.to_extended_list 0 deparsign'
+		else Context.Rel.to_extended_list 1 arsign'
 	      in nrpar@nrar
 
 	    in
@@ -400,14 +399,14 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let typtyi =
 	      let concl =
-		let pargs = if dep then Context.extended_rel_vect 0 deparsign
-		  else Context.extended_rel_vect 1 arsign
+		let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign
+		  else Context.Rel.to_extended_vect 1 arsign
 		in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
 	      in it_mkProd_or_LetIn_name env
 		concl
 		deparsign
 	    in
-	      mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
+	      mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp)
                 (deftyi::ldef) rest
         | [] ->
 	    let fixn = Array.of_list (List.rev ln) in
@@ -428,7 +427,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 	    else
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
 	      let recarg = recargpar@recarg in
-	      let vargs = Context.extended_rel_list (nrec+i+j) lnamesparrec in
+	      let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in
 	      let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
@@ -442,7 +441,7 @@ let mis_make_indrec env sigma listdepkind mib u =
     in
     let rec put_arity env i = function
       | ((indi,u),_,_,dep,kinds)::rest ->
-	  let indf = make_ind_family ((indi,u), Context.extended_rel_list i lnamesparrec) in
+	  let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in
 	  let s = 
 	    Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) 
 	      evdref kinds 
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index f429c51eb8..1e3ff0fa2d 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -12,7 +12,6 @@ open Names
 open Univ
 open Term
 open Vars
-open Context
 open Termops
 open Declarations
 open Declareops
@@ -142,12 +141,12 @@ let constructor_nallargs_env env ((kn,i),j) =
 
 let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *)
   let (mib,mip) = Global.lookup_inductive indsp in
-  mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+  mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
 
 let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *)
   let mib = Environ.lookup_mind kn env in
   let mip = mib.mind_packets.(i) in
-  mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+  mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
 
 (* Arity of constructors excluding params, excluding local defs *)
 
@@ -213,21 +212,21 @@ let inductive_nparams_env env ind =
 
 let inductive_nparamdecls ind =
   let (mib,mip) = Global.lookup_inductive ind in
-  rel_context_length mib.mind_params_ctxt
+  Context.Rel.length mib.mind_params_ctxt
 
 let inductive_nparamdecls_env env ind =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  rel_context_length mib.mind_params_ctxt
+  Context.Rel.length mib.mind_params_ctxt
 
 (* Full length of arity (with local defs) *)
 
 let inductive_nalldecls ind =
   let (mib,mip) = Global.lookup_inductive ind in
-  rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+  Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
 
 let inductive_nalldecls_env env ind =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+  Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
 
 (* Others *)
 
@@ -249,13 +248,13 @@ let inductive_alldecls_env env (ind,u) =
 
 let constructor_has_local_defs (indsp,j) =
   let (mib,mip) = Global.lookup_inductive indsp in
-  let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in
+  let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in
   let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in
   not (Int.equal l1 l2)
 
 let inductive_has_local_defs ind =
   let (mib,mip) = Global.lookup_inductive ind in
-  let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
+  let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
   let l2 = mib.mind_nparams + mip.mind_nrealargs in
   not (Int.equal l1 l2)
 
@@ -273,11 +272,11 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p
 let make_case_info env ind style =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let ind_tags =
-    rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
+    Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
   let cstr_tags =
     Array.map2 (fun c n ->
       let d,_ = decompose_prod_assum c in
-      rel_context_tags (List.firstn n d))
+      Context.Rel.to_tags (List.firstn n d))
       mip.mind_nf_lc mip.mind_consnrealdecls in
   let print_info = { ind_tags; cstr_tags; style } in
   { ci_ind     = ind;
@@ -292,7 +291,7 @@ type constructor_summary = {
   cs_cstr : pconstructor;
   cs_params : constr list;
   cs_nargs : int;
-  cs_args : rel_context;
+  cs_args : Context.Rel.t;
   cs_concl_realargs : constr array
 }
 
@@ -306,10 +305,10 @@ let lift_constructor n cs = {
 
 (* Accept either all parameters or only recursively uniform ones *)
 let instantiate_params t params sign =
-  let nnonrecpar = rel_context_nhyps sign - List.length params in
+  let nnonrecpar = Context.Rel.nhyps sign - List.length params in
   (* Adjust the signature if recursively non-uniform parameters are not here *)
   let _,sign = context_chop nnonrecpar sign in
-  let _,t = decompose_prod_n_assum (rel_context_length sign) t in
+  let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in
   let subst = subst_of_rel_context_instance sign params in
   substl subst t
 
@@ -323,7 +322,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) j =
   let vargs = List.skipn (List.length params) allargs in
   { cs_cstr = (ith_constructor_of_inductive ind j,u);
     cs_params = params;
-    cs_nargs = rel_context_length args;
+    cs_nargs = Context.Rel.length args;
     cs_args = args;
     cs_concl_realargs = Array.of_list vargs }
 
@@ -374,14 +373,14 @@ let build_dependent_constructor cs =
   applist
     (mkConstructU cs.cs_cstr,
      (List.map (lift cs.cs_nargs) cs.cs_params)
-      @(extended_rel_list 0 cs.cs_args))
+      @(Context.Rel.to_extended_list 0 cs.cs_args))
 
 let build_dependent_inductive env ((ind, params) as indf) =
   let arsign,_ = get_arity env indf in
   let nrealargs = List.length arsign in
   applist
     (mkIndU ind,
-     (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+     (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign))
 
 (* builds the arity of an elimination predicate in sort [s] *)
 
@@ -506,7 +505,7 @@ let set_pattern_names env ind brv =
   let arities =
     Array.map
       (fun c ->
-        rel_context_length ((prod_assum c)) -
+        Context.Rel.length ((prod_assum c)) -
         mib.mind_nparams)
       mip.mind_nf_lc in
   Array.map2 (set_names env) arities brv
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 9036f521ec..42a00a7e22 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Declarations
 open Environ
 open Evd
@@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int
 val inductive_nparamdecls_env : env -> inductive -> int
 
 (** @return params context *)
-val inductive_paramdecls : pinductive -> rel_context
-val inductive_paramdecls_env : env -> pinductive -> rel_context
+val inductive_paramdecls : pinductive -> Context.Rel.t
+val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t
 
 (** @return full arity context, hence with letin *)
-val inductive_alldecls : pinductive -> rel_context
-val inductive_alldecls_env : env -> pinductive -> rel_context
+val inductive_alldecls : pinductive -> Context.Rel.t
+val inductive_alldecls_env : env -> pinductive -> Context.Rel.t
 
 (** {7 Extract information from a constructor name} *)
 
@@ -133,9 +132,9 @@ val type_of_projection_knowing_arg : env -> evar_map -> Projection.t ->
 
 type constructor_summary = {
   cs_cstr : pconstructor;    (* internal name of the constructor plus universes *)
-  cs_params : constr list;  (* parameters of the constructor in current ctx *)
-  cs_nargs : int;           (* length of arguments signature (letin included) *)
-  cs_args : rel_context;    (* signature of the arguments (letin included) *)
+  cs_params : constr list;   (* parameters of the constructor in current ctx *)
+  cs_nargs : int;            (* length of arguments signature (letin included) *)
+  cs_args : Context.Rel.t;   (* signature of the arguments (letin included) *)
   cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *)
 }
 val lift_constructor : int -> constructor_summary -> constructor_summary
@@ -148,11 +147,11 @@ val get_projections  : env -> inductive_family -> constant array option
 (** [get_arity] returns the arity of the inductive family instantiated
     with the parameters; if recursively non-uniform parameters are not
     part of the inductive family, they appears in the arity *)
-val get_arity        : env -> inductive_family -> rel_context * sorts_family
+val get_arity        : env -> inductive_family -> Context.Rel.t * sorts_family
 
 val build_dependent_constructor : constructor_summary -> constr
 val build_dependent_inductive   : env -> inductive_family -> constr
-val make_arity_signature : env -> bool -> inductive_family -> rel_context
+val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t
 val make_arity : env -> bool -> inductive_family -> sorts -> types
 val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 0148280287..34191db344 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -6,7 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Context
 open Term
 open Globnames
 open Glob_term
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ce6d189855..6d9ed9a30c 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -28,7 +28,6 @@ open Names
 open Evd
 open Term
 open Vars
-open Context
 open Termops
 open Reductionops
 open Environ
@@ -311,7 +310,7 @@ let ltac_interp_name_env k0 lvar env =
      specification of pretype which accepts to start with a non empty
      rel_context) *)
   (* tail is the part of the env enriched by pretyping *)
-  let n = rel_context_length (rel_context env) - k0 in
+  let n = Context.Rel.length (rel_context env) - k0 in
   let ctxt,_ = List.chop n (rel_context env) in
   let env = pop_rel_context n env in
   let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in
@@ -529,14 +528,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
         let ty' = pretype_type empty_valcon env evdref lvar ty in
         let dcl = (na,None,ty'.utj_val) in
         let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in
-	  type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl
+	  type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl
       | (na,bk,Some bd,ty)::bl ->
         let ty' = pretype_type empty_valcon env evdref lvar ty in
         let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in
         let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
         let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in
-	  type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl in
-    let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+	  type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in
+    let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in
     let larj =
       Array.map2
         (fun e ar ->
@@ -563,7 +562,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
              (* we lift nbfix times the type in tycon, because of
 	      * the nbfix variables pushed to newenv *)
           let (ctxt,ty) =
-	    decompose_prod_n_assum (rel_context_length ctxt)
+	    decompose_prod_n_assum (Context.Rel.length ctxt)
               (lift nbfix ftys.(i)) in
           let nenv = push_rel_context ctxt newenv in
           let j = pretype (mk_tycon ty) nenv evdref lvar def in
@@ -884,7 +883,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       let pred = nf_evar !evdref pred in
       let p = nf_evar !evdref p in
       let f cs b =
-	let n = rel_context_length cs.cs_args in
+	let n = Context.Rel.length cs.cs_args in
 	let pi = lift n pred in (* liftn n 2 pred ? *)
 	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
 	let csgn =
@@ -1017,7 +1016,7 @@ and pretype_type k0 resolve_tc valcon env evdref lvar = function
 
 let ise_pretype_gen flags env sigma lvar kind c =
   let evdref = ref sigma in
-  let k0 = rel_context_length (rel_context env) in
+  let k0 = Context.Rel.length (rel_context env) in
   let c' = match kind with
     | WithoutTypeConstraint ->
         (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val
@@ -1059,7 +1058,7 @@ let on_judgment f j =
 
 let understand_judgment env sigma c =
   let evdref = ref sigma in
-  let k0 = rel_context_length (rel_context env) in
+  let k0 = Context.Rel.length (rel_context env) in
   let j = pretype k0 true empty_tycon env evdref empty_lvar c in
   let j = on_judgment (fun c ->
     let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in 
@@ -1067,7 +1066,7 @@ let understand_judgment env sigma c =
   in j, Evd.evar_universe_context !evdref
 
 let understand_judgment_tcc env evdref c =
-  let k0 = rel_context_length (rel_context env) in
+  let k0 = Context.Rel.length (rel_context env) in
   let j = pretype k0 true empty_tycon env evdref empty_lvar c in
   on_judgment (fun c ->
     let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 3f02e4bfb1..f59f880326 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -11,7 +11,6 @@ open Util
 open Names
 open Term
 open Vars
-open Context
 open Termops
 open Univ
 open Evd
@@ -1466,17 +1465,17 @@ let splay_prod_assum env sigma =
     match kind_of_term t with
     | Prod (x,t,c)  ->
 	prodec_rec (push_rel (x,None,t) env)
-	  (add_rel_decl (x, None, t) l) c
+	  (Context.Rel.add (x, None, t) l) c
     | LetIn (x,b,t,c) ->
 	prodec_rec (push_rel (x, Some b, t) env)
-	  (add_rel_decl (x, Some b, t) l) c
+	  (Context.Rel.add (x, Some b, t) l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> 
       let t' = whd_betadeltaiota env sigma t in
 	if Term.eq_constr t t' then l,t
 	else prodec_rec env l t'
   in
-  prodec_rec env empty_rel_context
+  prodec_rec env Context.Rel.empty
 
 let splay_arity env sigma c =
   let l, c = splay_prod env sigma c in
@@ -1491,20 +1490,20 @@ let splay_prod_n env sigma n =
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Prod (n,a,c0) ->
 	  decrec (push_rel (n,None,a) env)
-	    (m-1) (add_rel_decl (n,None,a) ln) c0
+	    (m-1) (Context.Rel.add (n,None,a) ln) c0
       | _                      -> invalid_arg "splay_prod_n"
   in
-  decrec env n empty_rel_context
+  decrec env n Context.Rel.empty
 
 let splay_lam_n env sigma n =
   let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Lambda (n,a,c0) ->
 	  decrec (push_rel (n,None,a) env)
-	    (m-1) (add_rel_decl (n,None,a) ln) c0
+	    (m-1) (Context.Rel.add (n,None,a) ln) c0
       | _                      -> invalid_arg "splay_lam_n"
   in
-  decrec env n empty_rel_context
+  decrec env n Context.Rel.empty
 
 let is_sort env sigma t =
   match kind_of_term (whd_betadeltaiota env sigma t) with
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 43c98bbd47..5195784a4c 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Context
 open Univ
 open Evd
 open Environ
@@ -218,10 +217,10 @@ val splay_prod : env ->  evar_map -> constr -> (Name.t * constr) list * constr
 val splay_lam : env ->  evar_map -> constr -> (Name.t * constr) list * constr
 val splay_arity : env ->  evar_map -> constr -> (Name.t * constr) list * sorts
 val sort_of_arity : env -> evar_map -> constr -> sorts
-val splay_prod_n : env ->  evar_map -> int -> constr -> rel_context * constr
-val splay_lam_n : env ->  evar_map -> int -> constr -> rel_context * constr
+val splay_prod_n : env ->  evar_map -> int -> constr -> Context.Rel.t * constr
+val splay_lam_n : env ->  evar_map -> int -> constr -> Context.Rel.t * constr
 val splay_prod_assum :
-  env ->  evar_map -> constr -> rel_context * constr
+  env ->  evar_map -> constr -> Context.Rel.t * constr
 val is_sort : env -> evar_map -> types -> bool
 
 type 'a miota_args = {
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 89ba46dbc4..70345c5092 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -8,7 +8,6 @@
 
 open Term
 open Evd
-open Context
 open Environ
 
 (** This family of functions assumes its constr argument is known to be
@@ -44,6 +43,6 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
 val type_of_global_reference_knowing_conclusion :
   env -> evar_map -> constr -> types -> evar_map * types
 
-val sorts_of_context : env -> evar_map -> rel_context -> sorts list
+val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list
 
 val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index deb03f5160..c4f22987f7 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -12,7 +12,6 @@ open Globnames
 open Decl_kinds
 open Term
 open Vars
-open Context
 open Evd
 open Util
 open Typeclasses_errors
@@ -59,10 +58,10 @@ type typeclass = {
   cl_impl : global_reference;
 
   (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *)
-  cl_context : (global_reference * bool) option list * rel_context;
+  cl_context : (global_reference * bool) option list * Context.Rel.t;
 
   (* Context of definitions and properties on defs, will not be shared *)
-  cl_props : rel_context;
+  cl_props : Context.Rel.t;
 
   (* The method implementaions as projections. *)
   cl_projs : (Name.t * (direction * int option) option * constant option) list;
@@ -127,7 +126,7 @@ let typeclass_univ_instance (cl,u') =
     in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) 
       Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u')
   in
-  let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in
+  let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in
     { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context);
       cl_props = subst_ctx cl.cl_props}, u'
 
@@ -204,7 +203,7 @@ let discharge_class (_,cl) =
 	(decl :: ctx', n :: subst)
     ) ctx ([], []) in
   let discharge_rel_context subst n rel =
-    let rel = map_rel_context (Cooking.expmod_constr repl) rel in
+    let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in
     let ctx, _ =
       List.fold_right
 	(fun (id, b, t) (ctx, k) ->
@@ -287,7 +286,7 @@ let build_subclasses ~check env sigma glob pri =
       | None -> []
       | Some (rels, ((tc,u), args)) ->
 	let instapp = 
-	  Reductionops.whd_beta sigma (appvectc c (Context.extended_rel_vect 0 rels))
+	  Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels))
 	in
 	let projargs = Array.of_list (args @ [instapp]) in
 	let projs = List.map_filter 
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index b3170b9702..f56af19a02 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -9,7 +9,6 @@
 open Names
 open Globnames
 open Term
-open Context
 open Evd
 open Environ
 
@@ -24,10 +23,10 @@ type typeclass = {
   (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses.
      The boolean indicates if the typeclass argument is a direct superclass and the global reference
      gives a direct link to the class itself. *)
-  cl_context : (global_reference * bool) option list * rel_context;
+  cl_context : (global_reference * bool) option list * Context.Rel.t;
 
   (** Context of definitions and properties on defs, will not be shared *)
-  cl_props : rel_context;
+  cl_props : Context.Rel.t;
 
   (** The methods implementations of the typeclass as projections. 
       Some may be undefinable due to sorting restrictions or simply undefined if 
@@ -68,7 +67,7 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list
 val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses
 
 (** Just return None if not a class *)
-val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option
+val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option
   
 val instance_impl : instance -> global_reference
 
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index 585f066db4..7a918ee876 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -9,7 +9,6 @@
 (*i*)
 open Names
 open Term
-open Context
 open Environ
 open Constrexpr
 open Globnames
@@ -20,7 +19,7 @@ type contexts = Parameters | Properties
 type typeclass_error =
     | NotAClass of constr
     | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *)
-    | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
+    | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 7982fc8524..b72d4db632 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -9,7 +9,6 @@
 open Loc
 open Names
 open Term
-open Context
 open Environ
 open Constrexpr
 open Globnames
@@ -19,7 +18,7 @@ type contexts = Parameters | Properties
 type typeclass_error =
   | NotAClass of constr
   | UnboundMethod of global_reference * Id.t located (** Class name, method *)
-  | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
+  | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
@@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a
 
 val unbound_method : env -> global_reference -> Id.t located -> 'a
 
-val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
+val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a
 
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index e8a0df4844..b42a70b340 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1582,7 +1582,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
     | AllOccurrences, InHyp as occ ->
         let occ = if likefirst then LikeFirst else AtOccs occ in
         let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
-        if Context.eq_named_declaration d newdecl
+        if Context.Named.Declaration.equal d newdecl
            && not (indirectly_dependent c d depdecls)
         then
           if check_occs && not (in_every_hyp occs)
@@ -1634,7 +1634,7 @@ type abstraction_request =
 
 type 'r abstraction_result =
   Names.Id.t * named_context_val *
-    Context.named_declaration list * Names.Id.t option *
+    Context.Named.Declaration.t list * Names.Id.t option *
     types * (constr, 'r) Sigma.sigma option
 
 let make_abstraction env evd ccl abs =
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 51a51f3752..14bcb4a06d 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -77,7 +77,7 @@ val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
 
 type 'r abstraction_result =
   Names.Id.t * named_context_val *
-    Context.named_declaration list * Names.Id.t option *
+    Context.Named.Declaration.t list * Names.Id.t option *
     types * (constr, 'r) Sigma.sigma option
 
 val make_abstraction : env -> 'r Sigma.t -> constr ->
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index c59e085e5b..38eea91700 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -53,7 +53,7 @@ let type_constructor mind mib u typ params =
   let s = ind_subst mind mib u in
   let ctyp = substl s typ in
   let ctyp = subst_instance_constr u ctyp in
-  let ndecls = Context.rel_context_length mib.mind_params_ctxt in
+  let ndecls = Context.Rel.length mib.mind_params_ctxt in
   if Int.equal ndecls 0 then ctyp
   else
     let _,ctyp = decompose_prod_n_assum ndecls ctyp in
-- 
cgit v1.2.3


From 4841b790bbe517deefac11e8df1a7a1494d56bec Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 12 Jan 2016 17:02:09 +0100
Subject: Fix essential bug in new Keyed Unification mode reported by R.
 Krebbers.

[rewrite] was calling find_suterm using the wrong unification flags, not
allowing full delta in unification of terms with the right keys as desired.
---
 pretyping/unification.ml  | 2 ++
 pretyping/unification.mli | 2 ++
 2 files changed, 4 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 9758aa43c4..510d5761b7 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -37,6 +37,8 @@ let _ = Goptions.declare_bool_option {
   Goptions.optwrite = (fun a -> keyed_unification:=a);
 }
 
+let is_keyed_unification () = !keyed_unification
+
 let debug_unification = ref (false)
 let _ = Goptions.declare_bool_option {
   Goptions.optsync = true; Goptions.optdepr = false;
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 119b1a7590..9246c10f90 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -42,6 +42,8 @@ val default_no_delta_unify_flags : unit -> unify_flags
 val elim_flags : unit -> unify_flags
 val elim_no_delta_flags : unit -> unify_flags
 
+val is_keyed_unification : unit -> bool
+
 (** The "unique" unification fonction *)
 val w_unify :
   env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map
-- 
cgit v1.2.3


From fc642ca962dd5228a5a714b8e41506dcbc3b6520 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 12 Jan 2016 19:27:02 +0100
Subject: Extend last commit: keyed unification uses full conversions on the
 applied constant and arguments _separately_.

---
 pretyping/unification.ml | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 510d5761b7..48638474a8 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1649,8 +1649,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) =
     let cl = strip_outer_cast cl in
     (try
        if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then
-	 (try w_typed_unify env evd CONV flags op cl,cl
-	  with ex when Pretype_errors.unsatisfiable_exception ex ->
+       (try
+         if !keyed_unification then
+           let f1, l1 = decompose_app_vect op in
+	   let f2, l2 = decompose_app_vect cl in
+	   w_typed_unify_array env evd flags f1 l1 f2 l2,cl
+	 else w_typed_unify env evd CONV flags op cl,cl
+       with ex when Pretype_errors.unsatisfiable_exception ex ->
 	    bestexn := Some ex; error "Unsat")
        else error "Bound 1"
      with ex when precatchable_exception ex ->
-- 
cgit v1.2.3


From be4bfc78c493464cb0af40d7fae08ba86295a6f9 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Tue, 12 Jan 2016 20:49:34 +0100
Subject: Fixing #4256 and #4484 (changes in evar-evar resolution made that new
 evars were created making in turn that evars formerly recognized as pending
 were not anymore in the list of pending evars). This also fixes the reopening
 of #3848.

See comments on #4484 for details.
---
 pretyping/pretyping.ml | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index faba5c7563..521fa2247b 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -183,22 +183,26 @@ type inference_flags = {
   expand_evars : bool
 }
 
+let frozen_holes (sigma, sigma') =
+  let fold evk _ accu = Evar.Set.add evk accu in
+  Evd.fold_undefined fold sigma Evar.Set.empty
+
 let pending_holes (sigma, sigma') =
   let fold evk _ accu =
     if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu
   in
   Evd.fold_undefined fold sigma' Evar.Set.empty
 
-let apply_typeclasses env evdref pending fail_evar =
-  let filter_pending evk = Evar.Set.mem evk pending in
+let apply_typeclasses env evdref frozen fail_evar =
+  let filter_frozen evk = Evar.Set.mem evk frozen in
   evdref := Typeclasses.resolve_typeclasses
      ~filter:(if Flags.is_program_mode () 
-	      then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && filter_pending evk)
-              else (fun evk evi -> Typeclasses.no_goals evk evi && filter_pending evk))
+	      then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk))
+              else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk)))
      ~split:true ~fail:fail_evar env !evdref;
   if Flags.is_program_mode () then (* Try optionally solving the obligations *)
     evdref := Typeclasses.resolve_typeclasses
-      ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && filter_pending evk) ~split:true ~fail:false env !evdref
+      ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env !evdref
 
 let apply_inference_hook hook evdref pending =
   evdref := Evar.Set.fold (fun evk sigma ->
@@ -219,9 +223,9 @@ let apply_heuristics env evdref fail_evar =
   with e when Errors.noncritical e ->
     let e = Errors.push e in if fail_evar then iraise e
 
-let check_typeclasses_instances_are_solved env current_sigma pending =
+let check_typeclasses_instances_are_solved env current_sigma frozen =
   (* Naive way, call resolution again with failure flag *)
-  apply_typeclasses env (ref current_sigma) pending true
+  apply_typeclasses env (ref current_sigma) frozen true
 
 let check_extra_evars_are_solved env current_sigma pending =
   Evar.Set.iter
@@ -233,26 +237,28 @@ let check_extra_evars_are_solved env current_sigma pending =
 	| _ ->
 	    error_unsolvable_implicit loc env current_sigma evk None) pending
 
-let check_evars_are_solved env current_sigma pending =
-  check_typeclasses_instances_are_solved env current_sigma pending;
+let check_evars_are_solved env current_sigma frozen pending =
+  check_typeclasses_instances_are_solved env current_sigma frozen;
   check_problems_are_solved env current_sigma;
   check_extra_evars_are_solved env current_sigma pending
 
 (* Try typeclasses, hooks, unification heuristics ... *)
 
 let solve_remaining_evars flags env current_sigma pending =
+  let frozen = frozen_holes pending in
   let pending = pending_holes pending in
   let evdref = ref current_sigma in
-  if flags.use_typeclasses then apply_typeclasses env evdref pending false;
+  if flags.use_typeclasses then apply_typeclasses env evdref frozen false;
   if Option.has_some flags.use_hook then
     apply_inference_hook (Option.get flags.use_hook env) evdref pending;
   if flags.use_unif_heuristics then apply_heuristics env evdref false;
-  if flags.fail_evar then check_evars_are_solved env !evdref pending;
+  if flags.fail_evar then check_evars_are_solved env !evdref frozen pending;
   !evdref
 
 let check_evars_are_solved env current_sigma pending =
+  let frozen = frozen_holes pending in
   let pending = pending_holes pending in
-  check_evars_are_solved env current_sigma pending
+  check_evars_are_solved env current_sigma frozen pending
 
 let process_inference_flags flags env initial_sigma (sigma,c) =
   let sigma = solve_remaining_evars flags env sigma (initial_sigma, sigma) in
-- 
cgit v1.2.3


From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Wed, 20 Jan 2016 17:25:10 +0100
Subject: Update copyright headers.

---
 pretyping/arguments_renaming.ml  | 2 +-
 pretyping/arguments_renaming.mli | 2 +-
 pretyping/cases.ml               | 2 +-
 pretyping/cases.mli              | 2 +-
 pretyping/cbv.ml                 | 2 +-
 pretyping/cbv.mli                | 2 +-
 pretyping/classops.ml            | 2 +-
 pretyping/classops.mli           | 2 +-
 pretyping/coercion.ml            | 2 +-
 pretyping/coercion.mli           | 2 +-
 pretyping/constr_matching.ml     | 2 +-
 pretyping/constr_matching.mli    | 2 +-
 pretyping/detyping.ml            | 2 +-
 pretyping/detyping.mli           | 2 +-
 pretyping/evarconv.ml            | 2 +-
 pretyping/evarconv.mli           | 2 +-
 pretyping/evarsolve.ml           | 2 +-
 pretyping/evarsolve.mli          | 2 +-
 pretyping/evarutil.ml            | 2 +-
 pretyping/evarutil.mli           | 2 +-
 pretyping/evd.ml                 | 2 +-
 pretyping/evd.mli                | 2 +-
 pretyping/find_subterm.ml        | 2 +-
 pretyping/find_subterm.mli       | 2 +-
 pretyping/glob_ops.ml            | 2 +-
 pretyping/glob_ops.mli           | 2 +-
 pretyping/indrec.ml              | 2 +-
 pretyping/indrec.mli             | 2 +-
 pretyping/inductiveops.ml        | 2 +-
 pretyping/inductiveops.mli       | 2 +-
 pretyping/locusops.ml            | 2 +-
 pretyping/locusops.mli           | 2 +-
 pretyping/miscops.ml             | 2 +-
 pretyping/miscops.mli            | 2 +-
 pretyping/namegen.ml             | 2 +-
 pretyping/namegen.mli            | 2 +-
 pretyping/nativenorm.ml          | 2 +-
 pretyping/nativenorm.mli         | 2 +-
 pretyping/patternops.ml          | 2 +-
 pretyping/patternops.mli         | 2 +-
 pretyping/pretype_errors.ml      | 2 +-
 pretyping/pretype_errors.mli     | 2 +-
 pretyping/pretyping.ml           | 2 +-
 pretyping/pretyping.mli          | 2 +-
 pretyping/program.ml             | 2 +-
 pretyping/program.mli            | 2 +-
 pretyping/recordops.ml           | 2 +-
 pretyping/recordops.mli          | 2 +-
 pretyping/redops.ml              | 2 +-
 pretyping/redops.mli             | 2 +-
 pretyping/reductionops.ml        | 2 +-
 pretyping/reductionops.mli       | 2 +-
 pretyping/retyping.ml            | 2 +-
 pretyping/retyping.mli           | 2 +-
 pretyping/tacred.ml              | 2 +-
 pretyping/tacred.mli             | 2 +-
 pretyping/termops.ml             | 2 +-
 pretyping/termops.mli            | 2 +-
 pretyping/typeclasses.ml         | 2 +-
 pretyping/typeclasses.mli        | 2 +-
 pretyping/typeclasses_errors.ml  | 2 +-
 pretyping/typeclasses_errors.mli | 2 +-
 pretyping/typing.ml              | 2 +-
 pretyping/typing.mli             | 2 +-
 pretyping/unification.ml         | 2 +-
 pretyping/unification.mli        | 2 +-
 pretyping/vnorm.ml               | 2 +-
 pretyping/vnorm.mli              | 2 +-
 68 files changed, 68 insertions(+), 68 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
index 3cfc0dc85a..ca1d0b7fba 100644
--- a/pretyping/arguments_renaming.ml
+++ b/pretyping/arguments_renaming.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
index 290bfc59fc..a334055011 100644
--- a/pretyping/arguments_renaming.mli
+++ b/pretyping/arguments_renaming.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index a5a7ace221..3d6fa38d0d 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index c599766ab7..ab00aa165e 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 21bbede093..43062a0e8d 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index bde85383de..de37d1fc5e 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 055996de55..ece92b66ba 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index e2bb2d1a00..cf88be629b 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 3163ac0e6e..489a311bc6 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index f511f977c3..68f9a2e681 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 5e99521a12..ee3c43d8da 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli
index b9dcb0af26..8d8166f22f 100644
--- a/pretyping/constr_matching.mli
+++ b/pretyping/constr_matching.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 67261def0b..c3877c56e4 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index eb158686aa..838588dc44 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index bb07bf0563..637a9e50e0 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 8bc30a7175..14947c8927 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index fe26dcd282..3bf6f37649 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index 86a1e3e0ce..918ba12f0f 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index b27803bd05..e23e5a53a7 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index f1d94b0a4f..f68651a74e 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 8edc7a17c6..01083142b7 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 117e52958b..0b4f185368 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 95a6ba79db..6733b7fca0 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 47d9654e57..28108f8ca0 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 3a76e8bd74..c9860864a9 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index 25746323fb..45444234a3 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 54d47fbe00..d5f6e9b301 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index f616c96792..4d81a59ef5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index cb091f2d6f..fb180b8b75 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 757599a3ce..7cd2ff2af5 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
index 4a5e11f0db..d89aeccd8c 100644
--- a/pretyping/locusops.ml
+++ b/pretyping/locusops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli
index 79dc373439..c7661239e3 100644
--- a/pretyping/locusops.mli
+++ b/pretyping/locusops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index a0ec1baae2..142e430ff8 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli
index 453648d4dc..337473a6fd 100644
--- a/pretyping/miscops.mli
+++ b/pretyping/miscops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
index a88c2e20e3..fc3f0cc75b 100644
--- a/pretyping/namegen.ml
+++ b/pretyping/namegen.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
index f66bc6d88c..6751bd3cf8 100644
--- a/pretyping/namegen.mli
+++ b/pretyping/namegen.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index de988aa2cd..6d09d56985 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index 0352038385..bbda55f486 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 83bf355cc2..af46c390a6 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 0148280287..5f877814d7 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 030b4a11c6..cf5b08c58f 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index 8fcfb59b3a..f617df9ee7 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 521fa2247b..ac0104d9f8 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 5f0e19cf2b..ac899a786e 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/program.ml b/pretyping/program.ml
index cac8a6a364..0bd121f6f1 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/program.mli b/pretyping/program.mli
index 3844f37547..b7ebcbc95c 100644
--- a/pretyping/program.mli
+++ b/pretyping/program.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 7fde7b7ac4..560beb6f1c 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index 37d5b4c278..a6a90c751b 100644
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/redops.ml b/pretyping/redops.ml
index 92782737e4..c188995a84 100644
--- a/pretyping/redops.ml
+++ b/pretyping/redops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/redops.mli b/pretyping/redops.mli
index 89c68ff321..f6d4d80862 100644
--- a/pretyping/redops.mli
+++ b/pretyping/redops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index bdd9ed81cf..13b7fb4079 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index d5a844847c..aea0a9ae2d 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index fb55265526..cb4e588eea 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 89ba46dbc4..37cec0c633 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 48911a5a9f..7c4f28cac8 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 03c4cb41c5..6a7248e197 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index ebd9d939aa..9d469cb715 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index 4581e23100..ca98f8d739 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 2ef2896506..3be98a1ae2 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index b3170b9702..9e018f6160 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index 585f066db4..a0f631984b 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 7982fc8524..7facb06f04 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index db980e455a..eb16628b10 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index bfae46ff80..dafd75231a 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 48638474a8..f97f6fbc57 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 9246c10f90..d5d5caf9ef 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index be772a6677..7d86fad922 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 9421b2d859..bdc6c1db6b 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
-- 
cgit v1.2.3


From ccdc62a6b4722c38f2b37cbf21b14e5094255390 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 21 Jan 2016 18:05:55 -0500
Subject: Fix bug #4506. Using betadeltaiota_nolet might produce terms of the
 form (let x := t in u) a that should be reduced. Maybe a different
 decomposition/reduction primitive should be used instead.

---
 pretyping/indrec.ml | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index d5f6e9b301..0588dcc87f 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -155,7 +155,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	| Prod (n,t,c) ->
 	    let d = (n,None,t) in
 	    make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
-	| LetIn (n,b,t,c) ->
+	| LetIn (n,b,t,c) when List.is_empty largs ->
 	    let d = (n,Some b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
      	| Ind (_,_) ->
@@ -166,7 +166,10 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
                 base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
             else
 	      base
-      	| _ -> assert false
+      	| _ ->
+	   let t' = whd_betadeltaiota env sigma p in
+	   if Term.eq_constr p' t' then assert false
+	   else prec env i sign t'
     in
     prec env 0 []
   in
@@ -230,14 +233,17 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	| Prod (n,t,c) ->
 	    let d = (n,None,t) in
 	    mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
-	| LetIn (n,b,t,c) ->
+	| LetIn (n,b,t,c) when List.is_empty largs ->
 	    let d = (n,Some b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = List.skipn nparrec largs
             and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
-     	| _ -> assert false
+     	| _ ->
+	   let t' = whd_betadeltaiota env sigma p in
+	     if Term.eq_constr t' p' then assert false
+	     else prec env i hyps t'
     in
     prec env 0 []
   in
-- 
cgit v1.2.3


From 6a046f8d3e33701d70e2a391741e65564cc0554d Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Sat, 23 Jan 2016 15:55:43 -0500
Subject: Fix bug #4519: oops, global shadowed local universe level bindings.

---
 pretyping/pretyping.ml | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ac0104d9f8..b33084a423 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -138,12 +138,12 @@ let interp_universe_level_name evd (loc,s) =
 	 in evd, level
     else 
       try
-	let id =
-	  try Id.of_string s with _ -> raise Not_found in
-	  evd, Idmap.find id names
+	let level = Evd.universe_of_name evd s in
+	evd, level
       with Not_found ->
-	try let level = Evd.universe_of_name evd s in
-	      evd, level
+	try 
+	  let id = try Id.of_string s with _ -> raise Not_found in
+	  evd, Idmap.find id names
 	with Not_found -> 
 	  if not (is_strict_universe_declarations ()) then
   	    new_univ_level_variable ~name:s univ_rigid evd
-- 
cgit v1.2.3


From 22a2cc1897f0d9f568ebfb807673e84f6ada491a Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 27 Jan 2016 09:36:47 +0100
Subject: Fix bug #4537: Coq 8.5 is slower in typeclass resolution.

The performance enhancement introduced by a895b2c0 for non-polymorphic hints
was actually causing a huge regression in the polymorphic case (and was marked
as such). We fix this by only substituting the metas from the evarmap instead
of the whole evarmap.
---
 pretyping/evd.ml  | 4 ++++
 pretyping/evd.mli | 1 +
 2 files changed, 5 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 01083142b7..5441145189 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1467,6 +1467,10 @@ let map_metas_fvalue f evd =
   in
   set_metas evd (Metamap.smartmap map evd.metas)
 
+let map_metas f evd =
+  let map cl = map_clb f cl in
+  set_metas evd (Metamap.smartmap map evd.metas)
+
 let meta_opt_fvalue evd mv =
   match Metamap.find mv evd.metas with
     | Clval(_,b,_) -> Some b
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 0b4f185368..9cfca02ed8 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -455,6 +455,7 @@ val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map
 
 val undefined_metas : evar_map -> metavariable list
 val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
+val map_metas : (constr -> constr) -> evar_map -> evar_map
 
 type metabinding = metavariable * constr * instance_status
 
-- 
cgit v1.2.3


From 7eeec8f82d96a71929289b0b9401a1b96e1d3dda Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 3 Feb 2016 10:26:28 +0100
Subject: More compact representation for evar resolvability flag.

This patch was proposed by JH in bug report #4547.
---
 pretyping/typeclasses.ml | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 3be98a1ae2..bb475cc554 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -495,15 +495,18 @@ let is_instance = function
 let resolvable = Store.field ()
 
 let set_resolvable s b =
-  Store.set s resolvable b
+  if b then Store.remove s resolvable
+  else Store.set s resolvable ()
 
 let is_resolvable evi =
   assert (match evi.evar_body with Evar_empty -> true | _ -> false);
-  Option.default true (Store.get evi.evar_extra resolvable)
+  Option.is_empty (Store.get evi.evar_extra resolvable)
 
 let mark_resolvability_undef b evi =
-  let t = Store.set evi.evar_extra resolvable b in
-  { evi with evar_extra = t }
+  if is_resolvable evi = b then evi
+  else
+    let t = set_resolvable evi.evar_extra b in
+    { evi with evar_extra = t }
 
 let mark_resolvability b evi =
   assert (match evi.evar_body with Evar_empty -> true | _ -> false);
-- 
cgit v1.2.3


From 0ee0b7d2f2365da6e63bc2e94d66f9c5fe1ebe6a Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 3 Feb 2016 11:28:34 +0100
Subject: Opacifying the type of evar naming structure in Evd.

---
 pretyping/evd.ml | 124 +++++++++++++++++++++++++++++++++----------------------
 1 file changed, 74 insertions(+), 50 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 5441145189..8be09a7821 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -575,34 +575,28 @@ type evar_constraint = conv_pb * Environ.env * constr * constr
 
 module EvMap = Evar.Map
 
-type evar_map = {
-  (** Existential variables *)
-  defn_evars : evar_info EvMap.t;
-  undf_evars : evar_info EvMap.t;
-  evar_names : Id.t EvMap.t * existential_key Idmap.t;
-  (** Universes *)
-  universes  : evar_universe_context;
-  (** Conversion problems *)
-  conv_pbs   : evar_constraint list;
-  last_mods  : Evar.Set.t;
-  (** Metas *)
-  metas      : clbinding Metamap.t;
-  (** Interactive proofs *)
-  effects    : Safe_typing.private_constants;
-  future_goals : Evar.t list; (** list of newly created evars, to be
-                                  eventually turned into goals if not solved.*)
-  principal_future_goal : Evar.t option; (** if [Some e], [e] must be
-                                             contained
-                                             [future_goals]. The evar
-                                             [e] will inherit
-                                             properties (now: the
-                                             name) of the evar which
-                                             will be instantiated with
-                                             a term containing [e]. *)
-  extras : Store.t;
-}
+module EvNames :
+sig
 
-(*** Lifting primitive from Evar.Map. ***)
+open Misctypes
+
+type t
+
+val empty : t
+val add_name_newly_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t
+val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t
+val remove_name_defined : Evar.t -> t -> t
+val rename : Evar.t -> Id.t -> t -> t
+val reassign_name_defined : Evar.t -> Evar.t -> t -> t
+val ident : Evar.t -> t -> Id.t
+val key : Id.t -> t -> Evar.t
+
+end =
+struct
+
+type t = Id.t EvMap.t * existential_key Idmap.t
+
+let empty = (EvMap.empty, Idmap.empty)
 
 let add_name_newly_undefined naming evk evi (evtoid,idtoev) =
   let id = match naming with
@@ -630,29 +624,65 @@ let remove_name_defined evk (evtoid,idtoev) =
   let id = EvMap.find evk evtoid in
   (EvMap.remove evk evtoid, Idmap.remove id idtoev)
 
-let remove_name_possibly_already_defined evk evar_names =
-  try remove_name_defined evk evar_names
-  with Not_found -> evar_names
-
-let rename evk id evd =
-  let (evtoid,idtoev) = evd.evar_names in
+let rename evk id (evtoid, idtoev) =
   let id' = EvMap.find evk evtoid in
   if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
-  { evd with evar_names =
-      (EvMap.add evk id evtoid (* overwrite old name *),
-       Idmap.add id evk (Idmap.remove id' idtoev)) }
+  (EvMap.add evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev))
 
 let reassign_name_defined evk evk' (evtoid,idtoev) =
   let id = EvMap.find evk evtoid in
   (EvMap.add evk' id (EvMap.remove evk evtoid),
    Idmap.add id evk' (Idmap.remove id idtoev))
 
+let ident evk (evtoid, _) =
+  try EvMap.find evk evtoid
+  with Not_found ->
+    (* Unnamed (non-dependent) evar *)
+    add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
+
+let key id (_, idtoev) =
+  Idmap.find id idtoev
+
+end
+
+type evar_map = {
+  (** Existential variables *)
+  defn_evars : evar_info EvMap.t;
+  undf_evars : evar_info EvMap.t;
+  evar_names : EvNames.t;
+  (** Universes *)
+  universes  : evar_universe_context;
+  (** Conversion problems *)
+  conv_pbs   : evar_constraint list;
+  last_mods  : Evar.Set.t;
+  (** Metas *)
+  metas      : clbinding Metamap.t;
+  (** Interactive proofs *)
+  effects    : Safe_typing.private_constants;
+  future_goals : Evar.t list; (** list of newly created evars, to be
+                                  eventually turned into goals if not solved.*)
+  principal_future_goal : Evar.t option; (** if [Some e], [e] must be
+                                             contained
+                                             [future_goals]. The evar
+                                             [e] will inherit
+                                             properties (now: the
+                                             name) of the evar which
+                                             will be instantiated with
+                                             a term containing [e]. *)
+  extras : Store.t;
+}
+
+(*** Lifting primitive from Evar.Map. ***)
+
+let rename evk id evd =
+  { evd with evar_names = EvNames.rename evk id evd.evar_names }
+
 let add d e i = match i.evar_body with
 | Evar_empty ->
-  let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
+  let evar_names = EvNames.add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
   { d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
 | Evar_defined _ ->
-  let evar_names = remove_name_possibly_already_defined e d.evar_names in
+  let evar_names = try EvNames.remove_name_defined e d.evar_names with Not_found -> d.evar_names in
   { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
 
 let remove d e =
@@ -783,7 +813,7 @@ let empty = {
   last_mods  = Evar.Set.empty;
   metas      = Metamap.empty;
   effects    = Safe_typing.empty_private_constants;
-  evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
+  evar_names = EvNames.empty; (* id<->key for undefined evars *)
   future_goals = [];
   principal_future_goal = None;
   extras = Store.empty;
@@ -819,14 +849,8 @@ let add_conv_pb ?(tail=false) pb d =
 
 let evar_source evk d = (find d evk).evar_source
 
-let evar_ident evk evd =
-  try EvMap.find evk (fst evd.evar_names)
-  with Not_found ->
-    (* Unnamed (non-dependent) evar *)
-    add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
-
-let evar_key id evd =
-  Idmap.find id (snd evd.evar_names)
+let evar_ident evk evd = EvNames.ident evk evd.evar_names
+let evar_key id evd = EvNames.key id evd.evar_names
 
 let define_aux def undef evk body =
   let oldinfo =
@@ -848,7 +872,7 @@ let define evk body evd =
   | [] ->  evd.last_mods
   | _ -> Evar.Set.add evk evd.last_mods
   in
-  let evar_names = remove_name_defined evk evd.evar_names in
+  let evar_names = EvNames.remove_name_defined evk evd.evar_names in
   { evd with defn_evars; undf_evars; last_mods; evar_names }
 
 let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole)) 
@@ -868,7 +892,7 @@ let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole))
     evar_candidates = candidates;
     evar_extra = store; }
   in
-  let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in
+  let evar_names = EvNames.add_name_newly_undefined naming evk evar_info evd.evar_names in
   { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names }
 
 let restrict evk evk' filter ?candidates evd =
@@ -877,7 +901,7 @@ let restrict evk evk' filter ?candidates evd =
     { evar_info with evar_filter = filter;
       evar_candidates = candidates;
       evar_extra = Store.empty } in
-  let evar_names = reassign_name_defined evk evk' evd.evar_names in
+  let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in
   let ctxt = Filter.filter_list filter (evar_context evar_info) in
   let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in
   let body = mkEvar(evk',id_inst) in
-- 
cgit v1.2.3


From 62c141be71dd3c542824c19429eac0fdd686c9cb Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 3 Feb 2016 18:39:15 +0100
Subject: Optimizing the computation of frozen evars.

---
 pretyping/unification.ml | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index f97f6fbc57..6cb1bc7028 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1450,9 +1450,7 @@ let default_matching_core_flags sigma =
   check_applied_meta_types = true;
   use_pattern_unification = false;
   use_meta_bound_pattern_unification = false;
-  frozen_evars =
-    fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
-      sigma Evar.Set.empty;
+  frozen_evars = Evar.Map.domain (Evd.undefined_map sigma);
   restrict_conv_on_strict_subterms = false;
   modulo_betaiota = false;
   modulo_eta = false;
-- 
cgit v1.2.3


From 34ef02fac1110673ae74c41c185c228ff7876de2 Mon Sep 17 00:00:00 2001
From: Matej Kosik
Date: Fri, 29 Jan 2016 10:13:12 +0100
Subject: CLEANUP: Context.{Rel,Named}.Declaration.t

  Originally, rel-context was represented as:

    Context.rel_context = Names.Name.t * Constr.t option * Constr.t

  Now it is represented as:

    Context.Rel.t = LocalAssum of Names.Name.t * Constr.t
                  | LocalDef of Names.Name.t * Constr.t * Constr.t

  Originally, named-context was represented as:

    Context.named_context = Names.Id.t * Constr.t option * Constr.t

  Now it is represented as:

    Context.Named.t = LocalAssum of Names.Id.t * Constr.t
                    | LocalDef of Names.Id.t * Constr.t * Constr.t

Motivation:

  (1) In "tactics/hipattern.ml4" file we define "test_strict_disjunction"
      function which looked like this:

        let test_strict_disjunction n lc =
          Array.for_all_i (fun i c ->
            match (prod_assum (snd (decompose_prod_n_assum n c))) with
            | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i)
            | _ -> false) 0 lc

      Suppose that you do not know about rel-context and named-context.
      (that is the case of people who just started to read the source code)
      Merlin would tell you that the type of the value you are destructing
      by "match" is:

        'a * 'b option * Constr.t                    (* worst-case scenario *)

      or

        Named.Name.t * Constr.t option * Constr.t    (* best-case scenario (?) *)

      To me, this is akin to wearing an opaque veil.
      It is hard to figure out the meaning of the values you are looking at.
      In particular, it is hard to discover the connection between the value
      we are destructing above and the datatypes and functions defined
      in the "kernel/context.ml" file.

      In this case, the connection is there, but it is not visible
      (between the function above and the "Context" module).

      ------------------------------------------------------------------------

      Now consider, what happens when the reader see the same function
      presented in the following form:

        let test_strict_disjunction n lc =
          Array.for_all_i (fun i c ->
            match (prod_assum (snd (decompose_prod_n_assum n c))) with
            | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i)
            | _ -> false) 0 lc

      If the reader haven't seen "LocalAssum" before, (s)he can use Merlin
      to jump to the corresponding definition and learn more.

      In this case, the connection is there, and it is directly visible
      (between the function above and the "Context" module).

  (2) Also, if we already have the concepts such as:
      - local declaration
      - local assumption
      - local definition
      and we describe these notions meticulously in the Reference Manual,
      then it is a real pity not to reinforce the connection
      of the actual code with the abstract description we published.
---
 pretyping/cases.ml           | 196 +++++++++++++++++++++++--------------------
 pretyping/coercion.ml        |  11 ++-
 pretyping/constr_matching.ml |  15 ++--
 pretyping/detyping.ml        |  36 ++++++--
 pretyping/evarconv.ml        |  34 ++++----
 pretyping/evarsolve.ml       | 131 +++++++++++++++++------------
 pretyping/evarutil.ml        |  94 +++++++++++++--------
 pretyping/find_subterm.ml    |  23 ++---
 pretyping/indrec.ml          |  48 ++++++-----
 pretyping/inductiveops.ml    |  11 +--
 pretyping/nativenorm.ml      |  21 ++---
 pretyping/patternops.ml      |   7 +-
 pretyping/pretyping.ml       |  62 +++++++-------
 pretyping/reductionops.ml    |  36 ++++----
 pretyping/retyping.ml        |  22 ++---
 pretyping/tacred.ml          |  54 +++++++-----
 pretyping/typeclasses.ml     |  37 ++++----
 pretyping/typing.ml          |  13 +--
 pretyping/unification.ml     |  27 +++---
 pretyping/vnorm.ml           |  14 ++--
 20 files changed, 504 insertions(+), 388 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 2cbf3a2650..dd58590923 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -28,6 +28,7 @@ open Evarutil
 open Evarsolve
 open Evarconv
 open Evd
+open Context.Rel.Declaration
 
 (* Pattern-matching errors *)
 
@@ -272,13 +273,13 @@ let inductive_template evdref env tmloc ind =
     | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in
    let (_,evarl,_) =
     List.fold_right
-      (fun (na,b,ty) (subst,evarl,n) ->
-	match b with
-        | None ->
+      (fun decl (subst,evarl,n) ->
+	match decl with
+        | LocalAssum (na,ty) ->
 	    let ty' = substl subst ty in
 	    let e = e_new_evar env evdref ~src:(hole_source n) ty' in
 	    (e::subst,e::evarl,n+1)
-	| Some b ->
+	| LocalDef (na,b,ty) ->
 	    (substl subst b::subst,evarl,n+1))
       arsign ([],[],1) in
    applist (mkIndU indu,List.rev evarl)
@@ -306,15 +307,15 @@ let binding_vars_of_inductive = function
   | NotInd _ -> []
   | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
 
-let extract_inductive_data env sigma (_,b,t) =
-  match b with
-  | None ->
+let extract_inductive_data env sigma decl =
+  match decl with
+  | LocalAssum (_,t) ->
     let tmtyp =
       try try_find_ind env sigma t None
       with Not_found -> NotInd (None,t) in
     let tmtypvars = binding_vars_of_inductive tmtyp in
     (tmtyp,tmtypvars)
-  | Some _ ->
+  | LocalDef (_,_,t) ->
     (NotInd (None, t), [])
 
 let unify_tomatch_with_patterns evdref env loc typ pats realnames =
@@ -427,7 +428,7 @@ let remove_current_pattern eqn =
 let push_current_pattern (cur,ty) eqn =
   match eqn.patterns with
     | pat::pats ->
-        let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in
+        let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in
 	{ eqn with
             rhs = { eqn.rhs with rhs_env = rhs_env };
 	    patterns = pats }
@@ -454,9 +455,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
 exception NotAdjustable
 
 let rec adjust_local_defs loc = function
-  | (pat :: pats, (_,None,_) :: decls) ->
+  | (pat :: pats, LocalAssum _ :: decls) ->
       pat :: adjust_local_defs loc (pats,decls)
-  | (pats, (_,Some _,_) :: decls) ->
+  | (pats, LocalDef _ :: decls) ->
       PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
   | [], [] -> []
   | _ -> raise NotAdjustable
@@ -528,9 +529,10 @@ let dependencies_in_pure_rhs nargs eqns =
   let deps_columns = matrix_transpose deps_rows in
   List.map (List.exists (fun x -> x)) deps_columns
 
-let dependent_decl a = function
-  | (na,None,t) -> dependent a t
-  | (na,Some c,t) -> dependent a t || dependent a c
+let dependent_decl a =
+  function
+  | LocalAssum (na,t) -> dependent a t
+  | LocalDef (na,c,t) -> dependent a t || dependent a c
 
 let rec dep_in_tomatch n = function
   | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
@@ -601,7 +603,7 @@ let relocate_index_tomatch n1 n2 =
       NonDepAlias :: genrec depth rest
   | Abstract (i,d) :: rest ->
       let i = relocate_rel n1 n2 depth i in
-      Abstract (i, Context.Rel.Declaration.map (relocate_index n1 n2 depth) d)
+      Abstract (i, map_constr (relocate_index n1 n2 depth) d)
       :: genrec (depth+1) rest in
   genrec 0
 
@@ -634,7 +636,7 @@ let replace_tomatch n c =
   | NonDepAlias  :: rest ->
       NonDepAlias :: replrec depth rest
   | Abstract (i,d) :: rest ->
-      Abstract (i, Context.Rel.Declaration.map (replace_term n c depth) d)
+      Abstract (i, map_constr (replace_term n c depth) d)
       :: replrec (depth+1) rest in
   replrec 0
 
@@ -659,7 +661,7 @@ let rec liftn_tomatch_stack n depth = function
       NonDepAlias :: liftn_tomatch_stack n depth rest
   | Abstract (i,d)::rest ->
       let i = if i<depth then i else i+n in
-      Abstract (i, Context.Rel.Declaration.map (liftn n depth) d)
+      Abstract (i, map_constr (liftn n depth) d)
       ::(liftn_tomatch_stack n (depth+1) rest)
 
 let lift_tomatch_stack n = liftn_tomatch_stack n 1
@@ -695,7 +697,7 @@ let merge_name get_name obj = function
 let merge_names get_name = List.map2 (merge_name get_name)
 
 let get_names env sign eqns =
-  let names1 = List.make (List.length sign) Anonymous in
+  let names1 = List.make (Context.Rel.length sign) Anonymous in
   (* If any, we prefer names used in pats, from top to bottom *)
   let names2,aliasname =
     List.fold_right
@@ -713,7 +715,7 @@ let get_names env sign eqns =
       (fun (l,avoid) d na ->
 	 let na =
 	   merge_name
-	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+	     (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid))
 	     d na
 	 in
          (na::l,(out_name na)::avoid))
@@ -727,18 +729,16 @@ let get_names env sign eqns =
 (* We now replace the names y1 .. yn y by the actual names       *)
 (* xi1 .. xin xi to be found in the i-th clause of the matrix    *)
 
-let set_declaration_name x (_,c,t) = (x,c,t)
-
-let recover_initial_subpattern_names = List.map2 set_declaration_name
+let recover_initial_subpattern_names = List.map2 set_name
 
 let recover_and_adjust_alias_names names sign =
   let rec aux = function
   | [],[] ->
       []
-  | x::names, (_,None,t)::sign ->
-      (x,(alias_of_pat x,None,t)) :: aux (names,sign)
-  | names, (na,(Some _ as c),t)::sign ->
-      (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign)
+  | x::names, LocalAssum (_,t)::sign ->
+      (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign)
+  | names, (LocalDef (na,_,_) as decl)::sign ->
+      (PatVar (Loc.ghost,na), decl) :: aux (names,sign)
   | _ -> assert false
   in
   List.split (aux (names,sign))
@@ -753,11 +753,12 @@ let push_rels_eqn_with_names sign eqn =
   let sign = recover_initial_subpattern_names subpatnames sign in
   push_rels_eqn sign eqn
 
-let push_generalized_decl_eqn env n (na,c,t) eqn =
-  let na = match na with
-  | Anonymous -> Anonymous
-  | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in
-  push_rels_eqn [(na,c,t)] eqn
+let push_generalized_decl_eqn env n decl eqn =
+  match get_name decl with
+  | Anonymous ->
+      push_rels_eqn [decl] eqn
+  | Name _ ->
+      push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn
 
 let drop_alias_eqn eqn =
   { eqn with alias_stack = List.tl eqn.alias_stack }
@@ -765,7 +766,7 @@ let drop_alias_eqn eqn =
 let push_alias_eqn alias eqn =
   let aliasname = List.hd eqn.alias_stack in
   let eqn = drop_alias_eqn eqn in
-  let alias = set_declaration_name aliasname alias in
+  let alias = set_name aliasname alias in
   push_rels_eqn [alias] eqn
 
 (**********************************************************************)
@@ -931,7 +932,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
   in
   let pred = extract_predicate ccl tms in
   (* Build the predicate properly speaking *)
-  let sign = List.map2 set_declaration_name (na::names) sign in
+  let sign = List.map2 set_name (na::names) sign in
   it_mkLambda_or_LetIn_name env pred sign
 
 (* [expand_arg] is used by [specialize_predicate]
@@ -1117,14 +1118,14 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
   let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
   | [], _ -> brs,tomatch,pred,[]
   | n::deps, Abstract (i,d) :: tomatch ->
-      let d = Context.Rel.Declaration.map (nf_evar evd) d in
-      let is_d = match d with (_, None, _) -> false | _ -> true in
+      let d = map_constr (nf_evar evd) d in
+      let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in
       if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck
                  && Array.exists (is_dependent_branch k) brs then
         (* Dependency in the current term to match and its dependencies is real *)
         let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in
         let inst = match d with
-        | (_, None, _) -> mkRel n :: inst
+        | LocalAssum _ -> mkRel n :: inst
         | _ -> inst
         in
         brs, Abstract (i,d) :: tomatch, pred, inst
@@ -1186,12 +1187,13 @@ let group_equations pb ind current cstrs mat =
 let rec generalize_problem names pb = function
   | [] -> pb, []
   | i::l ->
-      let (na,b,t as d) = Context.Rel.Declaration.map (lift i) (Environ.lookup_rel i pb.env) in
       let pb',deps = generalize_problem names pb l in
-      begin match (na, b) with
-      | Anonymous, Some _ -> pb', deps
+      let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in
+      begin match d with
+      | LocalDef (Anonymous,_,_) -> pb', deps
       | _ ->
-        let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
+	 (* for better rendering *)
+	let d = map_type (whd_betaiota !(pb.evdref)) d in
         let tomatch = lift_tomatch_stack 1 pb'.tomatch in
         let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
         { pb' with
@@ -1219,7 +1221,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
   (* that had matched constructor C *)
   let cs_args = const_info.cs_args in
   let names,aliasname = get_names pb.env cs_args eqns in
-  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+  let typs = List.map2 set_name names cs_args
+  in
 
   (* We build the matrix obtained by expanding the matching on *)
   (* "C x1..xn as x" followed by a residual matching on eqn into *)
@@ -1229,7 +1232,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
   (* We adjust the terms to match in the context they will be once the *)
   (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
   let typs' =
-    List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 typs in
+    List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in
 
   let extenv = push_rel_context typs pb.env in
 
@@ -1267,7 +1270,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
 
   let typs' =
     List.map2
-      (fun (tm,(tmtyp,_),(na,_,_)) deps ->
+      (fun (tm, (tmtyp,_), decl) deps ->
+        let na = get_name decl in
 	let na = match curname, na with
 	| Name _, Anonymous -> curname
 	| Name _, Name _ -> na
@@ -1391,7 +1395,7 @@ and shift_problem ((current,t),_,na) pb =
   let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
   let pb =
     { pb with
-       env = push_rel (na,Some current,ty) pb.env;
+       env = push_rel (LocalDef (na,current,ty)) pb.env;
        tomatch = tomatch;
        pred = lift_predicate 1 pred tomatch;
        history = pop_history pb.history;
@@ -1439,7 +1443,7 @@ and compile_generalization pb i d rest =
    ([false]). *)
 and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest =
   let f c t =
-    let alias = (na,Some c,t) in
+    let alias = LocalDef (na,c,t) in
     let pb =
       { pb with
          env = push_rel alias pb.env;
@@ -1575,9 +1579,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
     (* \--------------extenv------------/ *)
     let (p, _, _) = lookup_rel_id x (rel_context extenv) in
     let rec traverse_local_defs p =
-      match pi2 (lookup_rel p extenv) with
-      | Some c -> assert (isRel c); traverse_local_defs (p + destRel c)
-      | None -> p in
+      match lookup_rel p extenv with
+      | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c)
+      | LocalAssum _ -> p in
     let p = traverse_local_defs p in
     let u = lift (n' - n) u in
     try Some (p, u, expand_vars_in_term extenv u)
@@ -1622,7 +1626,7 @@ let abstract_tycon loc env evdref subst tycon extenv t =
      convertible subterms of the substitution *)
   let rec aux (k,env,subst as x) t =
     let t = whd_evar !evdref t in match kind_of_term t with
-    | Rel n when pi2 (lookup_rel n env) != None -> t
+    | Rel n when is_local_def (lookup_rel n env) -> t
     | Evar ev ->
         let ty = get_type_of env !evdref t in
 	let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in
@@ -1658,7 +1662,8 @@ let abstract_tycon loc env evdref subst tycon extenv t =
 	List.map (fun a -> not (isRel a) || dependent a u
                            || Int.Set.mem (destRel a) depvl) inst in
       let named_filter =
-	List.map (fun (id,_,_) -> dependent (mkVar id) u)
+        let open Context.Named.Declaration in
+	List.map (fun d -> dependent (mkVar (get_id d)) u)
 	  (named_context extenv) in
       let filter = Filter.make (rel_filter @ named_filter) in
       let candidates = u :: List.map mkRel vl in
@@ -1726,7 +1731,7 @@ let build_inversion_problem loc env sigma tms t =
 	List.rev_append patl patl',acc_sign,acc
     | (t, NotInd (bo,typ)) :: tms ->
       let pat,acc = make_patvar t acc in
-      let d = (alias_of_pat pat,None,typ) in
+      let d = LocalAssum (alias_of_pat pat,typ) in
       let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in
       pat::patl,acc_sign,acc in
   let avoid0 = ids_of_context env in
@@ -1743,7 +1748,7 @@ let build_inversion_problem loc env sigma tms t =
   let n = List.length sign in
 
   let decls =
-    List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 sign in
+    List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in
 
   let pb_env = push_rel_context sign env in
   let decls =
@@ -1753,8 +1758,8 @@ let build_inversion_problem loc env sigma tms t =
   let dep_sign = find_dependencies_signature (List.make n true) decls in
 
   let sub_tms =
-    List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) ->
-      let na = if List.is_empty deps then Anonymous else force_name na in
+    List.map2 (fun deps (tm, (tmtyp,_), decl) ->
+      let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in
       Pushed (true,((tm,tmtyp),deps,na)))
       dep_sign decls in
   let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
@@ -1815,7 +1820,8 @@ let build_inversion_problem loc env sigma tms t =
 let build_initial_predicate arsign pred =
   let rec buildrec n pred tmnames = function
     | [] -> List.rev tmnames,pred
-    | ((na,c,t)::realdecls)::lnames ->
+    | (decl::realdecls)::lnames ->
+        let na = get_name decl in
         let n' = n + List.length realdecls in
         buildrec (n'+1) pred (force_name na::tmnames) lnames
     | _ -> assert false
@@ -1827,7 +1833,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
     match tm with
       | NotInd (bo,typ) ->
 	  (match t with
-	    | None -> [na,Option.map (lift n) bo,lift n typ]
+	    | None -> (match bo with
+		       | None -> [LocalAssum (na, lift n typ)]
+		       | Some b -> [LocalDef (na, lift n b, lift n typ)])
 	    | Some (loc,_,_) ->
  	    user_err_loc (loc,"",
 	    str"Unexpected type annotation for a term of non inductive type."))
@@ -1845,8 +1853,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
 		      anomaly (Pp.str "Ill-formed 'in' clause in cases");
 		  List.rev realnal
 	      | None -> List.make nrealargs_ctxt Anonymous in
-	  (na,None,build_dependent_inductive env0 indf')
-	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+	  LocalAssum (na, build_dependent_inductive env0 indf')
+	  ::(List.map2 set_name realnal arsign) in
   let rec buildrec n = function
     | [],[] -> []
     | (_,tm)::ltm, (_,x)::tmsign ->
@@ -2027,7 +2035,7 @@ let constr_of_pat env evdref arsign pat avoid =
 	      let previd, id = prime avoid (Name (Id.of_string "wildcard")) in
 		Name id, id :: avoid
 	in
-	  (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, 
+	  (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty,
 	   (List.map (fun x -> mkRel 1) realargs), 1, avoid)
     | PatCstr (l,((_, i) as cstr),args,alias) ->
 	let cind = inductive_of_constructor cstr in
@@ -2044,7 +2052,8 @@ let constr_of_pat env evdref arsign pat avoid =
 	assert (Int.equal nb_args_constr (List.length args));
 	let patargs, args, sign, env, n, m, avoid =
 	  List.fold_right2
-	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
+	    (fun decl ua (patargs, args, sign, env, n, m, avoid)  ->
+               let t = get_type decl in
 	       let pat', sign', arg', typ', argtypargs, n', avoid =
 		 let liftt = liftn (List.length sign) (succ (List.length args)) t in
 		   typ env (substl args liftt, []) ua avoid
@@ -2066,7 +2075,7 @@ let constr_of_pat env evdref arsign pat avoid =
 	      Anonymous ->
 		pat', sign, app, apptype, realargs, n, avoid
 	    | Name id ->
-		let sign = (alias, None, lift m ty) :: sign in
+		let sign = LocalAssum (alias, lift m ty) :: sign in
 		let avoid = id :: avoid in
 		let sign, i, avoid =
 		  try
@@ -2078,14 +2087,14 @@ let constr_of_pat env evdref arsign pat avoid =
 		      (lift 1 app) (* aliased term *)
 		    in
 		    let neq = eq_id avoid id in
-		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+		      LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid
 		  with Reduction.NotConvertible -> sign, 1, avoid
 		in
 		  (* Mark the equality as a hole *)
 		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
   in
-  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
-    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+  let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in
+    pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid
 
 
 (* shadows functional version *)
@@ -2100,23 +2109,23 @@ match kind_of_term t with
 | Rel 0 -> true
 | _ -> false
 
-let rels_of_patsign l =
-  List.map (fun ((na, b, t) as x) ->
-    match b with
-      | Some t' when is_topvar t' -> (na, None, t)
-      | _ -> x) l
+let rels_of_patsign =
+  List.map (fun decl ->
+	    match decl with
+	    | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t)
+	    | _ -> decl)
 
 let vars_of_ctx ctx =
   let _, y =
-    List.fold_right (fun (na, b, t)  (prev, vars) ->
-      match b with
-	| Some t' when is_topvar t' ->
+    List.fold_right (fun decl (prev, vars) ->
+      match decl with
+	| LocalDef (na,t',t) when is_topvar t' ->
 	    prev,
 	    (GApp (Loc.ghost,
 		(GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), 
 		   [hole; GVar (Loc.ghost, prev)])) :: vars
 	| _ ->
-	    match na with
+	    match get_name decl with
 		Anonymous -> invalid_arg "vars_of_ctx"
 	      | Name n -> n, GVar (Loc.ghost, n) :: vars)
       ctx (Id.of_string "vars_of_ctx_error", [])
@@ -2225,7 +2234,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
 	     match ineqs with
 	     | None -> [], arity
 	     | Some ineqs ->
-		 [Anonymous, None, ineqs], lift 1 arity
+		 [LocalAssum (Anonymous, ineqs)], lift 1 arity
 	   in
 	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
 	     eqs_rels @ neqs_rels @ rhs_rels', arity
@@ -2236,7 +2245,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
 	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
 	 let _btype = evd_comb1 (Typing.type_of env) evdref bbody in
 	 let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in
-	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+	 let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in
 	 let branch =
 	   let bref = GVar (Loc.ghost, branch_name) in
 	     match vars_of_ctx rhs_rels with
@@ -2285,7 +2294,7 @@ let abstract_tomatch env tomatchs tycon =
 		 (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
 	       let name = next_ident_away (Id.of_string "filtered_var") names in
 		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
-	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
+	       LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx,
 	       name :: names, tycon)
       ([], [], [], tycon) tomatchs
   in List.rev prev, ctx, tycon
@@ -2293,7 +2302,7 @@ let abstract_tomatch env tomatchs tycon =
 let build_dependent_signature env evdref avoid tomatchs arsign =
   let avoid = ref avoid in
   let arsign = List.rev arsign in
-  let allnames = List.rev_map (List.map pi1) arsign in
+  let allnames = List.rev_map (List.map get_name) arsign in
   let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
   let eqs, neqs, refls, slift, arsign' =
     List.fold_left2
@@ -2309,11 +2318,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 	     (* Build the arity signature following the names in matched terms 
 		as much as possible *)
 	     let argsign = List.tl arsign in (* arguments in inverse application order *)
-	     let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
+	     let app_decl = List.hd arsign in (* The matched argument *)
+	     let appn = get_name app_decl in
+	     let appt = get_type app_decl in
 	     let argsign = List.rev argsign in (* arguments in application order *)
 	     let env', nargeqs, argeqs, refl_args, slift, argsign' =
 	       List.fold_left2
-		 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
+		 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl ->
+		    let name = get_name decl in
+		    let t = get_type decl in
 		    let argt = Retyping.get_type_of env !evdref arg in
 		    let eq, refl_arg =
 		      if Reductionops.is_conv env !evdref argt t then
@@ -2331,16 +2344,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 		    let previd, id =
 		      let name =
 			match kind_of_term arg with
-			Rel n -> pi1 (lookup_rel n env)
+			Rel n -> get_name (lookup_rel n env)
 			| _ -> name
 		      in
 			make_prime avoid name
 		    in
 		      (env, succ nargeqs,
-		       (Name (eq_id avoid previd), None, eq) :: argeqs,
+		       (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs,
 		       refl_arg :: refl_args,
 		       pred slift,
-		       (Name id, b, t) :: argsign'))
+		       set_name (Name id) decl :: argsign'))
 		 (env, neqs, [], [], slift, []) args argsign
 	     in
 	     let eq = mk_JMeq evdref
@@ -2351,22 +2364,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
 	     in
 	     let refl_eq = mk_JMeq_refl evdref ty tm in
 	     let previd, id = make_prime avoid appn in
-	       (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+	       ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs,
 		succ nargeqs,
 		refl_eq :: refl_args,
 		pred slift,
-		(((Name id, appb, appt) :: argsign') :: arsigns))
+		((set_name (Name id) app_decl :: argsign') :: arsigns))
 
 	 | _ -> (* Non dependent inductive or not inductive, just use a regular equality *)
-	     let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
+	     let decl = match arsign with [x] -> x | _ -> assert(false) in
+	     let name = get_name decl in
 	     let previd, id = make_prime avoid name in
-	     let arsign' = (Name id, b, typ) in
+	     let arsign' = set_name (Name id) decl in
 	     let tomatch_ty = type_of_tomatch ty in
 	     let eq =
 	       mk_eq evdref (lift nar tomatch_ty)
 		 (mkRel slift) (lift nar tm)
 	     in
-	       ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
+	       ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs,
 		(mk_eq_refl evdref tomatch_ty tm) :: refl_args,
 		pred slift, (arsign' :: []) :: arsigns))
       ([], 0, [], nar, []) tomatchs arsign
@@ -2440,7 +2454,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
   (* We push the initial terms to match and push their alias to rhs' envs *)
   (* names of aliases will be recovered from patterns (hence Anonymous here) *)
 
-  let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+  let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+			  | NotInd (Some b, t) -> LocalDef (na,b,t)
+			  | IsInd (typ,_,_) -> LocalAssum (na,typ) in
   let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
     
   let typs =
@@ -2513,7 +2529,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
     (* names of aliases will be recovered from patterns (hence Anonymous *)
     (* here) *)
 
-    let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+    let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+			    | NotInd (Some b,t) -> LocalDef (na,b,t)
+			    | IsInd (typ,_,_) -> LocalAssum (na,typ) in
     let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
 
     let typs =
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311bc6..9d5a6006de 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -142,6 +142,7 @@ let mu env evdref t =
 and coerce loc env evdref (x : Term.constr) (y : Term.constr)
     : (Term.constr -> Term.constr) option
     =
+  let open Context.Rel.Declaration in
   let rec coerce_unify env x y =
     let x = hnf env !evdref x and y = hnf env !evdref y in
       try
@@ -151,8 +152,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
   and coerce' env x y : (Term.constr -> Term.constr) option =
     let subco () = subset_coerce env evdref x y in
     let dest_prod c =
+      let open Context.Rel.Declaration in
       match Reductionops.splay_prod_n env ( !evdref) 1 c with
-      | [(na,b,t)], c -> (na,t), c
+      | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c
       | _ -> raise NoSubtacCoercion
     in
     let coerce_application typ typ' c c' l l' =
@@ -205,7 +207,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 	  let name' = 
 	    Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env))
 	  in
-	  let env' = push_rel (name', None, a') env in
+	  let env' = push_rel (LocalAssum (name', a')) env in
 	  let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
 	    (* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
 	  let coec1 = app_opt env' evdref c1 (mkRel 1) in
@@ -255,7 +257,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		       | _ -> raise NoSubtacCoercion
 		     in
 		     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
-		     let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in
+		     let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in
 		     let c2 = coerce_unify env' b b' in
 		       match c1, c2 with
 		       | None, None -> None
@@ -475,7 +477,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
 	  let name = match name with
 	    | Anonymous -> Name Namegen.default_dependent_ident
 	    | _ -> name in
-	  let env1 = push_rel (name,None,u1) env in
+	  let open Context.Rel.Declaration in
+	  let env1 = push_rel (LocalAssum (name,u1)) env in
 	  let (evd', v1) =
 	    inh_conv_coerce_to_fail loc env1 evd rigidonly
               (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 69c1dfb47a..4fb4112022 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -20,6 +20,7 @@ open Vars
 open Pattern
 open Patternops
 open Misctypes
+open Context.Rel.Declaration
 (*i*)
 
 (* Given a term with second-order variables in it,
@@ -254,15 +255,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
           sorec ctx env subst c1 c2
 
       | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+	  sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
-	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
+	  sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env)
             (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
@@ -271,7 +272,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
 	  let n = Context.Rel.length ctx_b2 in
           let n' = Context.Rel.length ctx_b2' in
 	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
-            let f l (na,_,t) = (Anonymous,na,t)::l in
+            let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in
 	    let ctx_br = List.fold_left f ctx ctx_b2 in
 	    let ctx_br' = List.fold_left f ctx ctx_b2' in
 	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
@@ -367,21 +368,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
       | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,None,c1) env in
+      let env' = Environ.push_rel (LocalAssum (x,c1)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | Prod (x,c1,c2) ->
       let next_mk_ctx = function
       | [c1; c2] -> mk_ctx (mkProd (x, c1, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,None,c1) env in
+      let env' = Environ.push_rel (LocalAssum (x,c1)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | LetIn (x,c1,t,c2) ->
       let next_mk_ctx = function
       | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2))
       | _ -> assert false
       in
-      let env' = Environ.push_rel (x,Some c1,t) env in
+      let env' = Environ.push_rel (LocalDef (x,c1,t)) env in
       try_aux [(env, c1); (env', c2)] next_mk_ctx next
   | App (c1,lc) ->
         let topdown = true in
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c8ecf91d33..67a8f01aa4 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -24,6 +24,7 @@ open Nametab
 open Mod_subst
 open Misctypes
 open Decl_kinds
+open Context.Named.Declaration
 
 let dl = Loc.ghost
 
@@ -33,8 +34,15 @@ let print_universes = Flags.univ_print
 (** If true, prints local context of evars, whatever print_arguments *)
 let print_evar_arguments = ref false
 
-let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env
-let add_name_opt na b t (nenv, env) = 
+let add_name na b t (nenv, env) =
+  let open Context.Rel.Declaration in
+  add_name na nenv, push_rel (match b with
+			      | None -> LocalAssum (na,t)
+			      | Some b -> LocalDef (na,b,t)
+			     )
+			     env
+
+let add_name_opt na b t (nenv, env) =
   match t with
   | None -> Termops.add_name na nenv, env
   | Some t -> add_name na b t (nenv, env)
@@ -510,11 +518,14 @@ let rec detype flags avoid env sigma t =
 	  else noparams ()
 
     | Evar (evk,cl) ->
-        let bound_to_itself_or_letin (id,b,_) c =
-          b != None ||
-	  try let n = List.index Name.equal (Name id) (fst env) in 
-	      isRelN n c
-	  with Not_found -> isVarId id c in
+        let bound_to_itself_or_letin decl c =
+          match decl with
+          | LocalDef _ -> true
+          | LocalAssum (id,_) ->
+	     try let n = List.index Name.equal (Name id) (fst env) in
+	         isRelN n c
+	     with Not_found -> isVarId id c
+        in
       let id,l =
         try
           let id = Evd.evar_ident evk sigma in
@@ -684,17 +695,24 @@ let detype_rel_context ?(lax=false) where avoid env sigma sign =
   let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
   let rec aux avoid env = function
   | [] -> []
-  | (na,b,t)::rest ->
+  | decl::rest ->
+      let open Context.Rel.Declaration in
+      let na = get_name decl in
+      let t = get_type decl in
       let na',avoid' =
 	match where with
 	| None -> na,avoid
 	| Some c ->
-	    if b != None then
+	    if is_local_def decl then
 	      compute_displayed_let_name_in
                 (RenamingElsewhereFor (fst env,c)) avoid na c
 	    else
 	      compute_displayed_name_in
                 (RenamingElsewhereFor (fst env,c)) avoid na c in
+      let b = match decl with
+	      | LocalAssum _ -> None
+	      | LocalDef (_,b,_) -> Some b
+      in
       let b' = Option.map (detype (lax,false) avoid env sigma) b in
       let t' = detype (lax,false) avoid env sigma t in
       (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 99e51330ef..020f998aa7 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -23,6 +23,7 @@ open Globnames
 open Evd
 open Pretype_errors
 open Sigma.Notations
+open Context.Rel.Declaration
 
 type unify_fun = transparent_state ->
   env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -55,12 +56,15 @@ let eval_flexible_term ts env evd c =
       then constant_opt_value_in env cu
       else None
   | Rel n ->
-      (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
-      with Not_found -> None)
+      (try match lookup_rel n env with
+           | LocalAssum _ -> None
+           | LocalDef (_,v,_) -> Some (lift n v)
+       with Not_found -> None)
   | Var id ->
       (try
 	 if is_transparent_variable ts id then
-	   let (_,v,_) = lookup_named id env in v
+           let open Context.Named.Declaration in
+	   lookup_named id env |> get_value
 	 else None
        with Not_found -> None)
   | LetIn (_,b,_,c) -> Some (subst1 b c)
@@ -394,7 +398,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
     assert (match sk with [] -> true | _ -> false);
     let (na,c1,c'1) = destLambda term in
     let c = nf_evar evd c1 in
-    let env' = push_rel (na,None,c) env in
+    let env' = push_rel (LocalAssum (na,c)) env in
     let out1 = whd_betaiota_deltazeta_for_iota_state
       (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in
     let out2 = whd_nored_state evd
@@ -561,7 +565,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
 	       let b = nf_evar i b1 in
 	       let t = nf_evar i t1 in
                let na = Nameops.name_max na1 na2 in
-	       evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+	       evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2);
 	     (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
 	and f2 i =
           let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1)
@@ -676,7 +680,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
            (fun i ->
 	     let c = nf_evar i c1 in
              let na = Nameops.name_max na1 na2 in
-	     evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
+	     evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)]
 
     | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
     | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1
@@ -735,7 +739,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
                (fun i ->
  	         let c = nf_evar i c1 in
                  let na = Nameops.name_max n1 n2 in
-	         evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)]
+	         evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)]
 
 	| Rel x1, Rel x2 ->
 	    if Int.equal x1 x2 then
@@ -912,6 +916,7 @@ let choose_less_dependent_instance evk evd term args =
   | [] -> None
   | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd)
 
+open Context.Named.Declaration
 let apply_on_subterm env evdref f c t =
   let rec applyrec (env,(k,c) as acc) t =
     (* By using eq_constr, we make an approximation, for instance, we *)
@@ -922,7 +927,7 @@ let apply_on_subterm env evdref f c t =
       match kind_of_term t with
       | Evar (evk,args) when Evd.is_undefined !evdref evk ->
           let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in
-          let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in
+          let g decl a = if is_local_assum decl then applyrec acc a else a in
           mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args)))
       | _ ->
         map_constr_with_binders_left_to_right
@@ -939,17 +944,17 @@ let filter_possible_projections c ty ctxt args =
   let fv2 = collect_vars (mkApp (c,args)) in
   let len = Array.length args in
   let tyvars = collect_vars ty in
-  List.map_i (fun i (id,b,_) ->
+  List.map_i (fun i decl ->
     let () = assert (i < len) in
     let a = Array.unsafe_get args i in
-    (match b with None -> false | Some c -> not (isRel c || isVar c)) ||
+    (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) ||
     a == c ||
     (* Here we make an approximation, for instance, we could also be *)
     (* interested in finding a term u convertible to c such that a occurs *)
     (* in u *)
     isRel a && Int.Set.mem (destRel a) fv1 ||
     isVar a && Id.Set.mem (destVar a) fv2 ||
-    Id.Set.mem id tyvars)
+    Id.Set.mem (get_id decl) tyvars)
     0 ctxt
 
 let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
@@ -980,17 +985,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
   let env_evar = evar_filtered_env evi in
   let sign = named_context_val env_evar in
   let ctxt = evar_filtered_context evi in
-  let instance = List.map mkVar (List.map pi1 ctxt) in
+  let instance = List.map mkVar (List.map get_id ctxt) in
 
   let rec make_subst = function
-  | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
+  | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c ->
       begin match occs with
       | Some _ ->
         error "Cannot force abstraction on identity instance."
       | None ->
         make_subst (ctxt',l,occsl)
       end
-  | (id,_,t)::ctxt', c::l, occs::occsl ->
+  | decl'::ctxt', c::l, occs::occsl ->
+      let (id,_,t) = to_tuple decl' in
       let evs = ref [] in
       let ty = Retyping.get_type_of env_rhs evd c in
       let filter' = filter_possible_projections c ty ctxt args in
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 0dd0ad2e08..a65394e17b 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -19,6 +19,7 @@ open Retyping
 open Reductionops
 open Evarutil
 open Pretype_errors
+open Context.Rel.Declaration
 
 let normalize_evar evd ev =
   match kind_of_term (whd_evar evd (mkEvar ev)) with
@@ -79,7 +80,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
 	if !modified then 
 	  evdref := Evd.add !evdref ev {evi with evar_concl = ty'}
 	else ()
-    | _ -> iter_constr (refresh_term_evars onevars false) t
+    | _ -> Constr.iter (refresh_term_evars onevars false) t
   and refresh_polymorphic_positions args pos =
     let rec aux i = function
       | Some l :: ls -> 
@@ -162,7 +163,8 @@ type 'a update =
 | UpdateWith of 'a
 | NoUpdate
 
-let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign
+open Context.Named.Declaration
+let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign
 
 let restrict_evar_key evd evk filter candidates =
   match filter, candidates with
@@ -205,6 +207,7 @@ let restrict_instance evd evk filter argsv =
   let evi = Evd.find evd evk in
   Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv
 
+open Context.Rel.Declaration
 let noccur_evar env evd evk c =
   let cache = ref Int.Set.empty (* cache for let-ins *) in
   let rec occur_rec (k, env as acc) c =
@@ -217,9 +220,9 @@ let noccur_evar env evd evk c =
            else Array.iter (occur_rec acc) args')
   | Rel i when i > k ->
       if not (Int.Set.mem (i-k) !cache) then
-      (match pi2 (Environ.lookup_rel i env) with
-       | None -> ()
-       | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b))
+      (match Environ.lookup_rel i env with
+       | LocalAssum _ -> ()
+       | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b))
   | Proj (p,c) -> 
     let c = 
       try Retyping.expand_projection env evd p c []
@@ -241,9 +244,11 @@ let noccur_evar env evd evk c =
    variable in its family of aliased variables *)
 
 let compute_var_aliases sign =
-  List.fold_right (fun (id,b,c) aliases ->
-    match b with
-    | Some t ->
+  let open Context.Named.Declaration in
+  List.fold_right (fun decl aliases ->
+    let id = get_id decl in
+    match decl with
+    | LocalDef (_,t,_) ->
         (match kind_of_term t with
         | Var id' ->
             let aliases_of_id =
@@ -251,27 +256,30 @@ let compute_var_aliases sign =
             Id.Map.add id (aliases_of_id@[t]) aliases
         | _ ->
             Id.Map.add id [t] aliases)
-    | None -> aliases)
+    | LocalAssum _ -> aliases)
     sign Id.Map.empty
 
 let compute_rel_aliases var_aliases rels =
-  snd (List.fold_right (fun (_,b,u) (n,aliases) ->
-    (n-1,
-     match b with
-     | Some t ->
-         (match kind_of_term t with
-         | Var id' ->
-             let aliases_of_n =
-               try Id.Map.find id' var_aliases with Not_found -> [] in
-             Int.Map.add n (aliases_of_n@[t]) aliases
-         | Rel p ->
-             let aliases_of_n =
-               try Int.Map.find (p+n) aliases with Not_found -> [] in
-             Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
-         | _ ->
-             Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
-     | None -> aliases))
-         rels (List.length rels,Int.Map.empty))
+  snd (List.fold_right
+	 (fun decl (n,aliases) ->
+	  (n-1,
+	   match decl with
+	   | LocalDef (_,t,u) ->
+	      (match kind_of_term t with
+	       | Var id' ->
+		  let aliases_of_n =
+		    try Id.Map.find id' var_aliases with Not_found -> [] in
+		  Int.Map.add n (aliases_of_n@[t]) aliases
+	       | Rel p ->
+		  let aliases_of_n =
+		    try Int.Map.find (p+n) aliases with Not_found -> [] in
+		  Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
+	       | _ ->
+		  Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
+	   | LocalAssum _ -> aliases)
+	 )
+	 rels
+	 (List.length rels,Int.Map.empty))
 
 let make_alias_map env =
   (* We compute the chain of aliases for each var and rel *)
@@ -305,13 +313,13 @@ let normalize_alias aliases x =
 let normalize_alias_var var_aliases id =
   destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id))
 
-let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+let extend_alias decl (var_aliases,rel_aliases) =
   let rel_aliases =
     Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l))
       rel_aliases Int.Map.empty in
   let rel_aliases =
-    match b with
-    | Some t ->
+    match decl with
+    | LocalDef(_,t,_) ->
         (match kind_of_term t with
         | Var id' ->
             let aliases_of_binder =
@@ -323,7 +331,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) =
             Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
         | _ ->
             Int.Map.add 1 [lift 1 t] rel_aliases)
-    | None -> rel_aliases in
+    | LocalAssum _ -> rel_aliases in
   (var_aliases, rel_aliases)
 
 let expand_alias_once aliases x =
@@ -429,16 +437,17 @@ let get_actual_deps aliases l t =
       | Rel n -> Int.Set.mem n fv_rels
       | _ -> assert false) l
 
+open Context.Named.Declaration
 let remove_instance_local_defs evd evk args =
   let evi = Evd.find evd evk in
   let len = Array.length args in
   let rec aux sign i = match sign with
   | [] ->
     let () = assert (i = len) in []
-  | (_, None, _) :: sign ->
+  | LocalAssum _ :: sign ->
     let () = assert (i < len) in
     (Array.unsafe_get args i) :: aux sign (succ i)
-  | (_, Some _, _) :: sign ->
+  | LocalDef _ :: sign ->
     aux sign (succ i)
   in
   aux (evar_filtered_context evi) 0
@@ -500,7 +509,8 @@ let solve_pattern_eqn env l c =
     match kind_of_term a with
       (* Rem: if [a] links to a let-in, do as if it were an assumption *)
       | Rel n ->
-          let d = Context.Rel.Declaration.map (lift n) (lookup_rel n env) in
+          let open Context.Rel.Declaration in
+          let d = map_constr (lift n) (lookup_rel n env) in
           mkLambda_or_LetIn d c'
       | Var id ->
           let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
@@ -529,9 +539,9 @@ let make_projectable_subst aliases sigma evi args =
   let evar_aliases = compute_var_aliases sign in
   let (_,full_subst,cstr_subst) =
     List.fold_right
-      (fun (id,b,c) (args,all,cstrs) ->
-        match b,args with
-        | None, a::rest ->
+      (fun decl (args,all,cstrs) ->
+        match decl,args with
+        | LocalAssum (id,c), a::rest ->
             let a = whd_evar sigma a in
             let cstrs =
               let a',args = decompose_app_vect a in
@@ -541,7 +551,7 @@ let make_projectable_subst aliases sigma evi args =
                   Constrmap.add (fst cstr) ((args,id)::l) cstrs
               | _ -> cstrs in
             (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
-        | Some c, a::rest ->
+        | LocalDef (id,c,_), a::rest ->
             let a = whd_evar sigma a in
             (match kind_of_term c with
             | Var id' ->
@@ -601,10 +611,12 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
   let sign1 = evar_hyps evi1 in
   let filter1 = evar_filter evi1 in
   let src = subterm_source evk1 evi1.evar_source in
-  let ids1 = List.map pi1 (named_context_of_val sign1) in
+  let ids1 = List.map get_id (named_context_of_val sign1) in
   let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in
+  let open Context.Rel.Declaration in
   let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
-    List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+    List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+      let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in
       let id = next_name_away na avoid in
       let evd,t_in_sign =
         let s = Retyping.get_sort_of env evd t_in_env in
@@ -612,13 +624,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
 	 ~status:univ_flexible (Some false) env evd (mkSort s) in
         define_evar_from_virtual_equation define_fun env evd src t_in_env
           ty_t_in_sign sign filter inst_in_env in
-      let evd,b_in_sign = match b with
-      | None -> evd,None
-      | Some b ->
+      let evd,b_in_sign = match d with
+      | LocalAssum _ -> evd,None
+      | LocalDef (_,b,_) ->
           let evd,b = define_evar_from_virtual_equation define_fun env evd src b
             t_in_sign sign filter inst_in_env in
           evd,Some b in
-      (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter,
+      (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter,
        (mkRel 1)::(List.map (lift 1) inst_in_env),
        (mkRel 1)::(List.map (lift 1) inst_in_sign),
        push_rel d env,evd,id::avoid))
@@ -756,9 +768,10 @@ let project_with_effects aliases sigma effects t subst =
   effects := p :: !effects;
   c
 
+open Context.Named.Declaration
 let rec find_solution_type evarenv = function
-  | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
-  | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
+  | (id,ProjectVar)::l -> get_type (lookup_named id evarenv)
+  | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv)
   | (id,ProjectEvar _)::l -> find_solution_type evarenv l
   | [] -> assert false
 
@@ -892,7 +905,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
  *)
 
 let set_of_evctx l =
-  List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l
+  List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l
 
 let filter_effective_candidates evi filter candidates =
   match filter with
@@ -924,7 +937,13 @@ let closure_of_filter evd evk = function
   | Some filter ->
   let evi = Evd.find_undefined evd evk in
   let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in
-  let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in
+  let test b decl = b || Idset.mem (get_id decl) vars ||
+                    match decl with
+                    | LocalAssum _ ->
+                       false
+                    | LocalDef (_,c,_) ->
+                       not (isRel c || isVar c)
+  in
   let newfilter = Filter.map_along test filter (evar_context evi) in
   (* Now ensure that restriction is at least what is was originally *)
   let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in
@@ -1280,7 +1299,7 @@ let occur_evar_upto_types sigma n c =
          seen := Evar.Set.add sp !seen;
 	 Option.iter occur_rec (existential_opt_value sigma e);
 	 occur_rec (existential_type sigma e))
-    | _ -> iter_constr occur_rec c
+    | _ -> Constr.iter occur_rec c
   in
   try occur_rec c; false with Occur -> true
 
@@ -1365,15 +1384,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
     let t = whd_evar !evdref t in
     match kind_of_term t with
     | Rel i when i>k ->
-        (match pi2 (Environ.lookup_rel (i-k) env') with
-        | None -> project_variable (mkRel (i-k))
-        | Some b ->
+        let open Context.Rel.Declaration in
+        (match Environ.lookup_rel (i-k) env' with
+        | LocalAssum _ -> project_variable (mkRel (i-k))
+        | LocalDef (_,b,_) ->
           try project_variable (mkRel (i-k))
           with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
     | Var id ->
-        (match pi2 (Environ.lookup_named id env') with
-        | None -> project_variable t
-        | Some b ->
+        (match Environ.lookup_named id env' with
+        | LocalAssum _ -> project_variable t
+        | LocalDef (_,b,_) ->
           try project_variable t
           with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
     | LetIn (na,b,u,c) ->
@@ -1453,7 +1473,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
     let names = ref Idset.empty in
     let rec is_id_subst ctxt s =
       match ctxt, s with
-      | ((id, _, _) :: ctxt'), (c :: s') ->
+      | (decl :: ctxt'), (c :: s') ->
+        let id = get_id decl in
         names := Idset.add id !names;
         isVarId id c && is_id_subst ctxt' s'
       | [], [] -> true
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 8c210e2833..343d3ef903 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -76,13 +76,15 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} =
   {utj_val=nf_evar sigma v;utj_type=t}
 
 let env_nf_evar sigma env =
+  let open Context.Rel.Declaration in
   process_rel_context
-    (fun d e -> push_rel (Context.Rel.Declaration.map (nf_evar sigma) d) e) env
+    (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env
 
 let env_nf_betaiotaevar sigma env =
+  let open Context.Rel.Declaration in
   process_rel_context
     (fun d e ->
-      push_rel (Context.Rel.Declaration.map (Reductionops.nf_betaiota sigma) d) e) env
+      push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
 
 let nf_evars_universes evm =
   Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) 
@@ -149,11 +151,16 @@ let is_ground_term evd t =
   not (has_undefined_evars evd t)
 
 let is_ground_env evd env =
-  let is_ground_decl = function
-      (_,Some b,_) -> is_ground_term evd b
+  let open Context.Rel.Declaration in
+  let is_ground_rel_decl = function
+    | LocalDef (_,b,_) -> is_ground_term evd b
     | _ -> true in
-  List.for_all is_ground_decl (rel_context env) &&
-  List.for_all is_ground_decl (named_context env)
+  let open Context.Named.Declaration in
+  let is_ground_named_decl = function
+    | LocalDef (_,b,_) -> is_ground_term evd b
+    | _ -> true in
+  List.for_all is_ground_rel_decl (rel_context env) &&
+  List.for_all is_ground_named_decl (named_context env)
 
 (* Memoization is safe since evar_map and environ are applicative
    structures *)
@@ -231,10 +238,11 @@ let non_instantiated sigma =
 (************************)
 
 let make_pure_subst evi args =
+  let open Context.Named.Declaration in
   snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
+    (fun decl (args,l) ->
       match args with
-        | a::rest -> (rest, (id,a)::l)
+        | a::rest -> (rest, (get_id decl, a)::l)
         | _ -> anomaly (Pp.str "Instance does not match its signature"))
     (evar_filtered_context evi) (Array.rev_to_list args,[]))
 
@@ -276,17 +284,15 @@ let subst2 subst vsubst c =
 
 let push_rel_context_to_named_context env typ =
   (* compute the instances relative to the named context and rel_context *)
-  let ids = List.map pi1 (named_context env) in
+  let open Context.Named.Declaration in
+  let ids = List.map get_id (named_context env) in
   let inst_vars = List.map mkVar ids in
   let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
-  let replace_var_named_declaration id0 id (id',b,t) =
+  let replace_var_named_declaration id0 id decl =
+    let id' = get_id decl in
     let id' = if Id.equal id0 id' then id else id' in
     let vsubst = [id0 , mkVar id] in
-    let b = match b with
-    | None -> None
-    | Some c -> Some (replace_vars vsubst c)
-    in
-    id', b, replace_vars vsubst t
+    decl |> set_id id' |> map_constr (replace_vars vsubst)
   in
   let replace_var_named_context id0 id  env =
     let nc = Environ.named_context env in
@@ -303,7 +309,12 @@ let push_rel_context_to_named_context env typ =
   (* We do keep the instances corresponding to local definition (see above) *)
   let (subst, vsubst, _, env) =
     Context.Rel.fold_outside
-      (fun (na,c,t) (subst, vsubst, avoid, env) ->
+      (fun decl (subst, vsubst, avoid, env) ->
+        let open Context.Rel.Declaration in
+        let na = get_name decl in
+	let c = get_value decl in
+	let t = get_type decl in
+        let open Context.Named.Declaration in
         let id =
           (* ppedrot: we want to infer nicer names for the refine tactic, but
              keeping at the same time backward compatibility in other code
@@ -321,7 +332,10 @@ let push_rel_context_to_named_context env typ =
                context. Unless [id] is a section variable. *)
             let subst = List.map (replace_vars [id0,mkVar id]) subst in
             let vsubst = (id0,mkVar id)::vsubst in
-            let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in
+            let d = match c with
+              | None -> LocalAssum (id0, subst2 subst vsubst t)
+              | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t)
+            in
             let env = replace_var_named_context id0  id env in
             (mkVar id0 :: subst, vsubst, id::avoid, push_named d env)
         | _ ->
@@ -329,7 +343,10 @@ let push_rel_context_to_named_context env typ =
                incorrect. We revert to a less robust behaviour where
                the new binder has name [id]. Which amounts to the same
                behaviour than when [id=id0]. *)
-	    let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in
+            let d = match c with
+              | None -> LocalAssum (id, subst2 subst vsubst t)
+              | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t)
+            in
 	    (mkVar id :: subst, vsubst, id::avoid, push_named d env)
       )
       (rel_context env) ~init:([], [], ids, env) in
@@ -477,7 +494,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
 	    let ctxt = Evd.evar_filtered_context evi in
 	    let (rids,filter) =
               List.fold_right2
-                (fun (rid, ob,c as h) a (ri,filter) ->
+                (fun h a (ri,filter) ->
                   try
                   (* Check if some id to clear occurs in the instance
                      a of rid in ev and remember the dependency *)
@@ -493,7 +510,8 @@ let rec check_and_clear_in_constr env evdref err ids c =
                     let () = Id.Map.iter check ri in
                   (* No dependency at all, we can keep this ev's context hyp *)
                     (ri, true::filter)
-                  with Depends id -> (Id.Map.add rid id ri, false::filter))
+                  with Depends id -> let open Context.Named.Declaration in
+                                     (Id.Map.add (get_id h) id ri, false::filter))
 		ctxt (Array.to_list l) (Id.Map.empty,[]) in
 	    (* Check if some rid to clear in the context of ev has dependencies
 	       in the type of ev and adjust the source of the dependency *)
@@ -528,11 +546,10 @@ let clear_hyps_in_evi_main env evdref hyps terms ids =
   let terms =
     List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
   let nhyps =
-    let check_context ((id,ob,c) as decl) =
-      let err = OccurHypInSimpleClause (Some id) in
-      let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in
-      let c' = check_and_clear_in_constr env evdref err ids c in
-      if ob == ob' && c == c' then decl else (id, ob', c')
+    let open Context.Named.Declaration in
+    let check_context decl =
+      let err = OccurHypInSimpleClause (Some (get_id decl)) in
+      map_constr (check_and_clear_in_constr env evdref err ids) decl
     in
     let check_value vk = match force_lazy_val vk with
     | None -> vk
@@ -570,11 +587,12 @@ let process_dependent_evar q acc evm is_dependent e =
   (* Queues evars appearing in the types of the goal (conclusion, then
      hypotheses), they are all dependent. *)
   queue_term q true evi.evar_concl;
-  List.iter begin fun (_,b,t) ->
-    queue_term q true t;
-    match b with
-    | None -> ()
-    | Some b -> queue_term q true b
+  List.iter begin fun decl ->
+    let open Context.Named.Declaration in
+    queue_term q true (get_type decl);
+    match decl with
+    | LocalAssum _ -> ()
+    | LocalDef (_,b,_) -> queue_term q true b
   end (Environ.named_context_of_val evi.evar_hyps);
   match evi.evar_body with
   | Evar_empty ->
@@ -625,11 +643,11 @@ let undefined_evars_of_term evd t =
   evrec Evar.Set.empty t
 
 let undefined_evars_of_named_context evd nc =
-  List.fold_right (fun (_, b, t) s ->
-    Option.fold_left (fun s t ->
-      Evar.Set.union s (undefined_evars_of_term evd t))
-      (Evar.Set.union s (undefined_evars_of_term evd t)) b)
-    nc Evar.Set.empty
+  let open Context.Named.Declaration in
+  Context.Named.fold_outside
+    (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c)))
+    nc
+    ~init:Evar.Set.empty
 
 let undefined_evars_of_evar_info evd evi =
   Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
@@ -709,6 +727,7 @@ let idx = Namegen.default_dependent_ident
 (* Refining an evar to a product *)
 
 let define_pure_evar_as_product evd evk =
+  let open Context.Named.Declaration in
   let evi = Evd.find_undefined evd evk in
   let evenv = evar_env evi in
   let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
@@ -717,7 +736,7 @@ let define_pure_evar_as_product evd evk =
   let evd1,(dom,u1) =
     new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
   let evd2,rng =
-    let newenv = push_named (id, None, dom) evenv in
+    let newenv = push_named (LocalAssum (id, dom)) evenv in
     let src = evar_source evk evd1 in
     let filter = Filter.extend 1 (evar_filter evi) in
       if is_prop_sort s then
@@ -756,6 +775,7 @@ let define_evar_as_product evd (evk,args) =
 *)
 
 let define_pure_evar_as_lambda env evd evk =
+  let open Context.Named.Declaration in
   let evi = Evd.find_undefined evd evk in
   let evenv = evar_env evi in
   let typ = whd_betadeltaiota evenv evd (evar_concl evi) in
@@ -766,7 +786,7 @@ let define_pure_evar_as_lambda env evd evk =
   let avoid = ids_of_named_context (evar_context evi) in
   let id =
     next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
-  let newenv = push_named (id, None, dom) evenv in
+  let newenv = push_named (LocalAssum (id, dom)) evenv in
   let filter = Filter.extend 1 (evar_filter evi) in
   let src = evar_source evk evd1 in
   let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 6733b7fca0..ae8b91c346 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -59,19 +59,22 @@ let proceed_with_occurrences f occs x =
 (** Applying a function over a named_declaration with an hypothesis
     location request *)
 
-let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
-  let f = f (Some (id,hyploc)) in
-  match bodyopt,hyploc with
-  | None, InHypValueOnly ->
+let map_named_declaration_with_hyploc f hyploc acc decl =
+  let open Context.Named.Declaration in
+  let f = f (Some (get_id decl, hyploc)) in
+  match decl,hyploc with
+  | LocalAssum (id,_), InHypValueOnly ->
       error_occurrences_error (IncorrectInValueOccurrence id)
-  | None, _ | Some _, InHypTypeOnly ->
-      let acc,typ = f acc typ in acc,(id,bodyopt,typ)
-  | Some body, InHypValueOnly ->
-      let acc,body = f acc body in acc,(id,Some body,typ)
-  | Some body, InHyp ->
+  | LocalAssum (id,typ), _ ->
+      let acc,typ = f acc typ in acc, LocalAssum (id,typ)
+  | LocalDef (id,body,typ), InHypTypeOnly ->
+      let acc,typ = f acc typ in acc, LocalDef (id,body,typ)
+  | LocalDef (id,body,typ), InHypValueOnly ->
+      let acc,body = f acc body in acc, LocalDef (id,body,typ)
+  | LocalDef (id,body,typ), InHyp ->
       let acc,body = f acc body in
       let acc,typ = f acc typ in
-      acc,(id,Some body,typ)
+      acc, LocalDef (id,body,typ)
 
 (** Finding a subterm up to some testing function *)
 
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index fb45be6635..713c99597a 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -28,6 +28,7 @@ open Environ
 open Reductionops
 open Nametab
 open Sigma.Notations
+open Context.Rel.Declaration
 
 type dep_flag = bool
 
@@ -77,7 +78,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
   (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
   let env' = push_rel_context lnamespar env in
 
-
   let rec add_branch env k =
     if Int.equal k (Array.length mip.mind_consnames) then
       let nbprod = k+1 in
@@ -85,7 +85,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       let indf' = lift_inductive_family nbprod indf in
       let arsign,_ = get_arity env indf' in
       let depind = build_dependent_inductive env indf' in
-      let deparsign = (Anonymous,None,depind)::arsign in
+      let deparsign = LocalAssum (Anonymous,depind)::arsign in
 
       let ci = make_case_info env (fst pind) RegularStyle in
       let pbody =
@@ -118,14 +118,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
       let cs = lift_constructor (k+1) constrs.(k) in
       let t = build_branch_type env dep (mkRel (k+1)) cs in
       mkLambda_string "f" t
-	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
+	(add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1))
   in
   let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
   let typP = make_arity env' dep indf s in
   let c = 
     it_mkLambda_or_LetIn_name env
     (mkLambda_string "P" typP
-     (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
+     (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar
   in
   Sigma (c, sigma, p)
 
@@ -154,10 +154,10 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
       let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
       match kind_of_term p' with
 	| Prod (n,t,c) ->
-	    let d = (n,None,t) in
+	    let d = LocalAssum (n,t) in
 	    make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
 	| LetIn (n,b,t,c) when List.is_empty largs ->
-	    let d = (n,Some b,t) in
+	    let d = LocalDef (n,b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
      	| Ind (_,_) ->
 	    let realargs = List.skipn nparams largs in
@@ -192,22 +192,22 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	     | None ->
 		 make_prod env
 		   (n,t,
-		    process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+		    process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest
 		      (nhyps-1) (i::li))
              | Some(dep',p) ->
 		 let nP = lift (i+1+decP) p in
-                 let env' = push_rel (n,None,t) env in
+                 let env' = push_rel (LocalAssum (n,t)) env in
 		 let t_0 = process_pos env' dep' nP (lift 1 t) in
 		 make_prod_dep (dep || dep') env
                    (n,t,
 		    mkArrow t_0
 		      (process_constr
-			(push_rel (Anonymous,None,t_0) env')
+			(push_rel (LocalAssum (Anonymous,t_0)) env')
 			 (i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
       | LetIn (n,b,t,c_0) ->
 	  mkLetIn (n,b,t,
 		   process_constr
-		     (push_rel (n,Some b,t) env)
+		     (push_rel (LocalDef (n,b,t)) env)
 		     (i+1) c_0 recargs (nhyps-1) li)
       | _ -> assert false
     else
@@ -232,10 +232,10 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
       let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
       match kind_of_term p' with
 	| Prod (n,t,c) ->
-	    let d = (n,None,t) in
+	    let d = LocalAssum (n,t) in
 	    mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
 	| LetIn (n,b,t,c) when List.is_empty largs ->
-	    let d = (n,Some b,t) in
+	    let d = LocalDef (n,b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = List.skipn nparrec largs
@@ -250,7 +250,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   in
   (* ici, cstrprods est la liste des produits du constructeur instantié *)
   let rec process_constr env i f = function
-    | (n,None,t as d)::cprest, recarg::rest ->
+    | (LocalAssum (n,t) as d)::cprest, recarg::rest ->
         let optionpos =
 	  match dest_recarg recarg with
             | Norec   -> None
@@ -271,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 		 (n,t,process_constr env' (i+1)
 		    (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg])))
 		    (cprest,rest)))
-    | (n,Some c,t as d)::cprest, rest ->
+    | (LocalDef (n,c,t) as d)::cprest, rest ->
 	mkLetIn
 	  (n,c,t,
 	   process_constr (push_rel d env) (i+1) (lift 1 f)
@@ -322,7 +322,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let arsign,_ = get_arity env indf in
 	    let depind = build_dependent_inductive env indf in
-	    let deparsign = (Anonymous,None,depind)::arsign in
+	    let deparsign = LocalAssum (Anonymous,depind)::arsign in
 
 	    let nonrecpar = Context.Rel.length lnonparrec in
 	    let larsign = Context.Rel.length deparsign in
@@ -357,7 +357,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 
 	    let depind' = build_dependent_inductive env indf' in
 	    let arsign',_ = get_arity env indf' in
-	    let deparsign' = (Anonymous,None,depind')::arsign' in
+	    let deparsign' = LocalAssum (Anonymous,depind')::arsign' in
 
 	    let pargs =
 	      let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec
@@ -387,11 +387,13 @@ let mis_make_indrec env sigma listdepkind mib u =
 		    let branch = branches.(0) in
 		    let ctx, br = decompose_lam_assum branch in
 		    let n, subst = 
-		      List.fold_right (fun (na,b,t) (i, subst) ->
-			if b == None then 
-			  let t = mkProj (Projection.make ps.(i) true, mkRel 1) in
-			    (i + 1, t :: subst)
-			else (i, mkRel 0 :: subst))
+		      List.fold_right (fun decl (i, subst) ->
+			match decl with
+			| LocalAssum (na,t) ->
+			    let t = mkProj (Projection.make ps.(i) true, mkRel 1) in
+			    i + 1, t :: subst
+			| LocalDef (na,b,t) ->
+			    i, mkRel 0 :: subst)
 			ctx (0, [])
 		    in
 		    let term = substl subst br in
@@ -440,7 +442,7 @@ let mis_make_indrec env sigma listdepkind mib u =
                   true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg
 	      in
 		mkLambda_string "f" p_0
-		  (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
+		  (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1))
 	  in onerec env 0
       | [] ->
 	  makefix i listdepkind
@@ -454,7 +456,7 @@ let mis_make_indrec env sigma listdepkind mib u =
 	  in
 	  let typP = make_arity env dep indf s in
 	    mkLambda_string "P" typP
-	      (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
+	      (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest)
       | [] ->
 	  make_branch env 0 listdepkind
     in
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index bb38c72f25..80f1988a97 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -17,6 +17,7 @@ open Declarations
 open Declareops
 open Environ
 open Reductionops
+open Context.Rel.Declaration
 
 (* The following three functions are similar to the ones defined in
    Inductive, but they expect an env *)
@@ -389,7 +390,7 @@ let make_arity_signature env dep indf =
   if dep then
     (* We need names everywhere *)
     Namegen.name_context env
-      ((Anonymous,None,build_dependent_inductive env indf)::arsign)
+      ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign)
       (* Costly: would be better to name once for all at definition time *)
   else
     (* No need to enforce names *)
@@ -459,7 +460,7 @@ let is_predicate_explicitly_dep env pred arsign =
   let rec srec env pval arsign =
     let pv' = whd_betadeltaiota env Evd.empty pval in
     match kind_of_term pv', arsign with
-      | Lambda (na,t,b), (_,None,_)::arsign ->
+      | Lambda (na,t,b), (LocalAssum _)::arsign ->
 	  srec (push_rel_assum (na,t) env) b arsign
       | Lambda (na,_,t), _ ->
 
@@ -539,11 +540,11 @@ let arity_of_case_predicate env (ind,params) dep k =
    that appear in the type of the inductive by the sort of the
    conclusion, and the other ones by fresh universes. *)
 let rec instantiate_universes env evdref scl is = function
-  | (_,Some _,_ as d)::sign, exp ->
+  | (LocalDef _ as d)::sign, exp ->
       d :: instantiate_universes env evdref scl is (sign, exp)
   | d::sign, None::exp ->
       d :: instantiate_universes env evdref scl is (sign, exp)
-  | (na,None,ty)::sign, Some l::exp ->
+  | (LocalAssum (na,ty))::sign, Some l::exp ->
       let ctx,_ = Reduction.dest_arity env ty in
       let u = Univ.Universe.make l in
       let s =
@@ -557,7 +558,7 @@ let rec instantiate_universes env evdref scl is = function
 	  let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in
 	    evdref := evm; s
       in
-      (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp)
+      (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp)
   | sign, [] -> sign (* Uniform parameters are exhausted *)
   | [], _ -> assert false
 
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 6d09d56985..8ddfeaf2f0 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -19,6 +19,7 @@ open Util
 open Nativecode
 open Nativevalues
 open Nativelambda
+open Context.Rel.Declaration
 
 (** This module implements normalization by evaluation to OCaml code *)
 
@@ -121,9 +122,8 @@ let build_case_type dep p realargs c =
   else mkApp(p, realargs)
 
 (* TODO move this function *)
-let type_of_rel env n = 
-  let (_,_,ty) = lookup_rel n env in
-  lift n ty
+let type_of_rel env n =
+  lookup_rel n env |> get_type |> lift n
 
 let type_of_prop = mkSort type1_sort
 
@@ -132,8 +132,9 @@ let type_of_sort s =
   | Prop _ -> type_of_prop
   | Type u -> mkType (Univ.super u)
 
-let type_of_var env id = 
-  try let (_,_,ty) = lookup_named id env in ty
+let type_of_var env id =
+  let open Context.Named.Declaration in
+  try lookup_named id env |> get_type
   with Not_found ->
     anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
 
@@ -181,7 +182,7 @@ let rec nf_val env v typ =
           Errors.anomaly
             (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
       in
-      let env = push_rel (name,None,dom) env in
+      let env = push_rel (LocalAssum (name,dom)) env in
       let body = nf_val env (f (mk_rel_accu lvl)) codom in
       mkLambda(name,dom,body)
   | Vconst n -> construct_of_constr_const env n typ
@@ -257,7 +258,7 @@ and nf_atom env atom =
   | Aprod(n,dom,codom) ->
       let dom = nf_type env dom in
       let vn = mk_rel_accu (nb_rel env) in
-      let env = push_rel (n,None,dom) env in
+      let env = push_rel (LocalAssum (n,dom)) env in
       let codom = nf_type env (codom vn) in
       mkProd(n,dom,codom)
   | Ameta (mv,_) -> mkMeta mv
@@ -328,7 +329,7 @@ and nf_atom_type env atom =
   | Aprod(n,dom,codom) ->
       let dom,s1 = nf_type_sort env dom in
       let vn = mk_rel_accu (nb_rel env) in
-      let env = push_rel (n,None,dom) env in
+      let env = push_rel (LocalAssum (n,dom)) env in
       let codom,s2 = nf_type_sort env (codom vn) in
       mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2)
   | Aevar(ev,ty) ->
@@ -356,7 +357,7 @@ and  nf_predicate env ind mip params v pT =
 	    (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
       in
       let dep,body = 
-	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+	nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
   | Vfun f, _ -> 
       let k = nb_rel env in
@@ -366,7 +367,7 @@ and  nf_predicate env ind mip params v pT =
       let rargs = Array.init n (fun i -> mkRel (n-i)) in
       let params = if Int.equal n 0 then params else Array.map (lift n) params in
       let dom = mkApp(mkIndU ind,Array.append params rargs) in
-      let body = nf_type (push_rel (name,None,dom) env) vb in
+      let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_type env v
 
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index af46c390a6..827071054a 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -123,6 +123,7 @@ let head_of_constr_reference c = match kind_of_term c with
 
 let pattern_of_constr env sigma t =
   let rec pattern_of_constr env t =
+  let open Context.Rel.Declaration in
   match kind_of_term t with
     | Rel n  -> PRel n
     | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n)))
@@ -132,11 +133,11 @@ let pattern_of_constr env sigma t =
     | Sort (Type _) -> PSort (GType [])
     | Cast (c,_,_)      -> pattern_of_constr env c
     | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,
-				  pattern_of_constr (push_rel (na,Some c,t) env) b)
+				  pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b)
     | Prod (na,c,b)   -> PProd (na,pattern_of_constr env c,
-				pattern_of_constr (push_rel (na, None, c) env) b)
+				pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
     | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c,
-				  pattern_of_constr (push_rel (na, None, c) env) b)
+				  pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
     | App (f,a) ->
         (match
           match kind_of_term f with
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 11fba7b941..7c91b1a934 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -42,6 +42,7 @@ open Glob_ops
 open Evarconv
 open Pattern
 open Misctypes
+open Context.Named.Declaration
 
 type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
 type var_map = constr_under_binders Id.Map.t
@@ -319,7 +320,7 @@ let ltac_interp_name_env k0 lvar env =
   let n = Context.Rel.length (rel_context env) - k0 in
   let ctxt,_ = List.chop n (rel_context env) in
   let env = pop_rel_context n env in
-  let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in
+  let ctxt = List.map (Context.Rel.Declaration.map_name (ltac_interp_name lvar)) ctxt in
   push_rel_context ctxt env
 
 let invert_ltac_bound_name lvar env id0 id =
@@ -372,8 +373,7 @@ let pretype_id pretype k0 loc env evdref lvar id =
           str "Variable " ++ pr_id id ++ str " should be bound to a term.");
       (* Check if [id] is a section or goal variable *)
       try
-	let (_,_,typ) = lookup_named id env in
-	  { uj_val  = mkVar id; uj_type = typ }
+	  { uj_val  = mkVar id; uj_type = (get_type (lookup_named id env)) }
       with Not_found ->
 	  (* [id] not found, standard error message *)
 	  error_var_not_found_loc loc id
@@ -418,8 +418,7 @@ let pretype_ref loc evdref env ref us =
   match ref with
   | VarRef id ->
       (* Section variable *)
-      (try let (_,_,ty) = lookup_named id env in
-	     make_judge (mkVar id) ty
+      (try make_judge (mkVar id) (get_type (lookup_named id env))
        with Not_found ->
          (* This may happen if env is a goal env and section variables have
             been cleared - section variables should be different from goal
@@ -459,6 +458,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
   let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
   let pretype_type = pretype_type k0 resolve_tc in
   let pretype = pretype k0 resolve_tc in
+  let open Context.Rel.Declaration in
   match t with
   | GRef (loc,ref,u) ->
       inh_conv_coerce_to_tycon loc env evdref
@@ -518,14 +518,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     [] -> ctxt
       | (na,bk,None,ty)::bl ->
         let ty' = pretype_type empty_valcon env evdref lvar ty in
-        let dcl = (na,None,ty'.utj_val) in
-        let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in
+	let dcl = LocalAssum (na, ty'.utj_val) in
+        let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in
 	  type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl
       | (na,bk,Some bd,ty)::bl ->
         let ty' = pretype_type empty_valcon env evdref lvar ty in
         let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in
-        let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
-        let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in
+        let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in
+        let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in
 	  type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in
     let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in
     let larj =
@@ -694,7 +694,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     (* The name specified by ltac is used also to create bindings. So
        the substitution must also be applied on variables before they are
        looked up in the rel context. *)
-    let var = (name,None,j.utj_val) in
+    let var = LocalAssum (name, j.utj_val) in
     let j' = pretype rng (push_rel var env) evdref lvar c2 in
     let name = ltac_interp_name lvar name in
     let resj = judge_of_abstraction env (orelse_name name name') j j' in
@@ -738,7 +738,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     (* The name specified by ltac is used also to create bindings. So
        the substitution must also be applied on variables before they are
        looked up in the rel context. *)
-    let var = (name,Some j.uj_val,t) in
+    let var = LocalDef (name, j.uj_val, t) in
     let tycon = lift_tycon 1 tycon in
     let j' = pretype tycon (push_rel var env) evdref lvar c2 in
     let name = ltac_interp_name lvar name in
@@ -763,17 +763,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	int cs.cs_nargs ++ str " variables.");
     let fsign, record = 
       match get_projections env indf with
-      | None -> List.map2 (fun na (_,c,t) -> (na,c,t))
-	(List.rev nal) cs.cs_args, false
+      | None ->
+	 List.map2 set_name (List.rev nal) cs.cs_args, false
       | Some ps ->
 	let rec aux n k names l =
 	  match names, l with
-	  | na :: names, ((_, None, t) :: l) -> 
+	  | na :: names, (LocalAssum (_,t) :: l) ->
 	    let proj = Projection.make ps.(cs.cs_nargs - k) true in
-	      (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t)
+	    LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t)
 	    :: aux (n+1) (k + 1) names l
-	  | na :: names, ((_, c, t) :: l) -> 
-	    (na, c, t) :: aux (n+1) k names l
+	  | na :: names, (decl :: l) ->
+	    set_name na decl :: aux (n+1) k names l
 	  | [], [] -> []
 	  | _ -> assert false
 	in aux 1 1 (List.rev nal) cs.cs_args, true in
@@ -781,7 +781,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       if not record then 
         let nal = List.map (fun na -> ltac_interp_name lvar na) nal in
         let nal = List.rev nal in
-        let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in
+        let fsign = List.map2 set_name nal fsign in
 	let f = it_mkLambda_or_LetIn f fsign in
 	let ci = make_case_info env (fst ind) LetStyle in
 	  mkCase (ci, p, cj.uj_val,[|f|]) 
@@ -792,10 +792,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     let arsgn =
       let arsgn,_ = get_arity env indf in
 	if not !allow_anonymous_refs then
-	  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	  List.map (set_name Anonymous) arsgn
 	else arsgn
     in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in
       let nar = List.length arsgn in
 	  (match po with
 	  | Some p ->
@@ -851,11 +851,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	let arsgn,_ = get_arity env indf in
 	  if not !allow_anonymous_refs then
 	      (* Make dependencies from arity signature impossible *)
-	    List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	    List.map (set_name Anonymous) arsgn
 	  else arsgn
       in
       let nar = List.length arsgn in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in
       let pred,p = match po with
 	| Some p ->
 	  let env_p = push_rel_context psign env in
@@ -880,14 +880,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
 	let csgn =
 	  if not !allow_anonymous_refs then
-	    List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+	    List.map (set_name Anonymous) cs.cs_args
 	  else
-	    List.map
-	      (fun (n, b, t) ->
-		match n with
-                  Name _ -> (n, b, t)
-                | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t))
-	      cs.cs_args
+	    List.map (map_name (function Name _ as n -> n
+				       | Anonymous -> Name Namegen.default_non_dependent_ident))
+		     cs.cs_args
 	in
 	let env_c = push_rel_context csgn env in
 	let bj = pretype (mk_tycon pi) env_c evdref lvar b in
@@ -949,8 +946,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
     in inh_conv_coerce_to_tycon loc env evdref cj tycon
 
 and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
-  let f (id,_,t) (subst,update) =
-    let t = replace_vars subst t in
+  let f decl (subst,update) =
+    let id = get_id decl in
+    let t = replace_vars subst (get_type decl) in
     let c, update =
       try
         let c = List.assoc id update in
@@ -962,7 +960,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
         if is_conv env !evdref t t' then mkRel n, update else raise Not_found
       with Not_found ->
       try
-        let (_,_,t') = lookup_named id env in
+        let t' = lookup_named id env |> get_type in
         if is_conv env !evdref t t' then mkVar id, update else raise Not_found
       with Not_found ->
         user_err_loc (loc,"",str "Cannot interpret " ++
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 5e21154a67..d7637d1c27 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -15,6 +15,7 @@ open Termops
 open Univ
 open Evd
 open Environ
+open Context.Rel.Declaration
 
 exception Elimconst
 
@@ -607,7 +608,7 @@ let strong whdfun env sigma t =
   strongrec env t
 
 let local_strong whdfun sigma =
-  let rec strongrec t = map_constr strongrec (whdfun sigma t) in
+  let rec strongrec t = Constr.map strongrec (whdfun sigma t) in
   strongrec
 
 let rec strong_prodspine redfun sigma c =
@@ -799,6 +800,7 @@ let equal_stacks (x, l) (y, l') =
     | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) 
 
 let rec whd_state_gen ?csts tactic_mode flags env sigma =
+  let open Context.Named.Declaration in
   let rec whrec cst_l (x, stack as s) =
     let () = if !debug_RAKAM then
 	let open Pp in
@@ -815,11 +817,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
     match kind_of_term x with
     | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA ->
       (match lookup_rel n env with
-      | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack)
+      | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack)
       | _ -> fold ())
     | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) ->
       (match lookup_named id env with
-      | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
+      | LocalDef (_,body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
       | _ -> fold ())
     | Evar ev ->
       (match safe_evar_value sigma ev with
@@ -922,7 +924,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
       | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
 	apply_subst whrec [] cst_l x stack
       | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
-	let env' = push_rel (na,None,t) env in
+	let env' = push_rel (LocalAssum (na,t)) env in
 	let whrec' = whd_state_gen tactic_mode flags env' sigma in
         (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with
         | App (f,cl) ->
@@ -1442,7 +1444,7 @@ let splay_prod env sigma =
     let t = whd_betadeltaiota env sigma c in
     match kind_of_term t with
       | Prod (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
+	  decrec (push_rel (LocalAssum (n,a)) env)
 	    ((n,a)::m) c0
       | _ -> m,t
   in
@@ -1453,7 +1455,7 @@ let splay_lam env sigma =
     let t = whd_betadeltaiota env sigma c in
     match kind_of_term t with
       | Lambda (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
+	  decrec (push_rel (LocalAssum (n,a)) env)
 	    ((n,a)::m) c0
       | _ -> m,t
   in
@@ -1464,11 +1466,11 @@ let splay_prod_assum env sigma =
     let t = whd_betadeltaiota_nolet env sigma c in
     match kind_of_term t with
     | Prod (x,t,c)  ->
-	prodec_rec (push_rel (x,None,t) env)
-	  (Context.Rel.add (x, None, t) l) c
+	prodec_rec (push_rel (LocalAssum (x,t)) env)
+	  (Context.Rel.add (LocalAssum (x,t)) l) c
     | LetIn (x,b,t,c) ->
-	prodec_rec (push_rel (x, Some b, t) env)
-	  (Context.Rel.add (x, Some b, t) l) c
+	prodec_rec (push_rel (LocalDef (x,b,t)) env)
+	  (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> 
       let t' = whd_betadeltaiota env sigma t in
@@ -1489,8 +1491,8 @@ let splay_prod_n env sigma n =
   let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Prod (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
-	    (m-1) (Context.Rel.add (n,None,a) ln) c0
+	  decrec (push_rel (LocalAssum (n,a)) env)
+	    (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
       | _                      -> invalid_arg "splay_prod_n"
   in
   decrec env n Context.Rel.empty
@@ -1499,8 +1501,8 @@ let splay_lam_n env sigma n =
   let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Lambda (n,a,c0) ->
-	  decrec (push_rel (n,None,a) env)
-	    (m-1) (Context.Rel.add (n,None,a) ln) c0
+	  decrec (push_rel (LocalAssum (n,a)) env)
+	    (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
       | _                      -> invalid_arg "splay_lam_n"
   in
   decrec env n Context.Rel.empty
@@ -1538,8 +1540,8 @@ let find_conclusion env sigma =
   let rec decrec env c =
     let t = whd_betadeltaiota env sigma c in
     match kind_of_term t with
-      | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
-      | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
+      | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
       | t -> t
   in
   decrec env
@@ -1623,7 +1625,7 @@ let meta_reducible_instance evd b =
 	  with
 	    | Some g -> irec (mkProj (p,g))
 	    | None -> mkProj (p,c))
-    | _ -> map_constr irec u
+    | _ -> Constr.map irec u
   in
   if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus
   else irec b.rebus
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index cb4e588eea..1a6f7832aa 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -18,6 +18,7 @@ open Reductionops
 open Environ
 open Termops
 open Arguments_renaming
+open Context.Rel.Declaration
 
 type retype_error =
   | NotASort
@@ -71,13 +72,14 @@ let rec subst_type env sigma typ = function
 let sort_of_atomic_type env sigma ft args =
   let rec concl_of_arity env n ar args =
     match kind_of_term (whd_betadeltaiota env sigma ar), args with
-    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l
+    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l
     | Sort s, [] -> s
     | _ -> retype_error NotASort
   in concl_of_arity env 0 ft (Array.to_list args)
 
 let type_of_var env id =
-  try let (_,_,ty) = lookup_named id env in ty
+  let open Context.Named.Declaration in
+  try get_type (lookup_named id env)
   with Not_found -> retype_error (BadVariable id)
 
 let decomp_sort env sigma t =
@@ -86,13 +88,13 @@ let decomp_sort env sigma t =
   | _ -> retype_error NotASort
 
 let retype ?(polyprop=true) sigma =
-  let rec type_of env cstr=
+  let rec type_of env cstr =
     match kind_of_term cstr with
     | Meta n ->
       (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
        with Not_found -> retype_error (BadMeta n))
     | Rel n ->
-        let (_,_,ty) = lookup_rel n env in
+	let ty = get_type (lookup_rel n env) in
         lift n ty
     | Var id -> type_of_var env id
     | Const cst -> rename_type_of_constant env cst
@@ -115,9 +117,9 @@ let retype ?(polyprop=true) sigma =
           | Prod _ -> whd_beta sigma (applist (t, [c]))
           | _ -> t)
     | Lambda (name,c1,c2) ->
-          mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+          mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2)
     | LetIn (name,b,c1,c2) ->
-         subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
+         subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2)
     | Fix ((_,i),(_,tys,_)) -> tys.(i)
     | CoFix (i,(_,tys,_)) -> tys.(i)
     | App(f,args) when is_template_polymorphic env f ->
@@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma =
     | Sort (Prop c) -> type1_sort
     | Sort (Type u) -> Type (Univ.super u)
     | Prod (name,t,c2) ->
-        (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
+        (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with
 	  | _, (Prop Null as s) -> s
           | Prop _, (Prop Pos as s) -> s
           | Type _, (Prop Pos as s) when is_impredicative_set env -> s
@@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma =
     | Sort (Prop c) -> InType
     | Sort (Type u) -> InType
     | Prod (name,t,c2) ->
-	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
+	let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in
 	if not (is_impredicative_set env) &&
 	   s2 == InSet && sort_family_of env t == InType then InType else s2
     | App(f,args) when is_template_polymorphic env f ->
@@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
 let sorts_of_context env evc ctxt =
   let rec aux = function
   | [] -> env,[]
-  | (_,_,t as d)::ctxt ->
+  | d :: ctxt ->
       let env,sorts = aux ctxt in
-      let s = get_sort_of env evc t in
+      let s = get_sort_of env evc (get_type d) in
       (push_rel d env,s::sorts) in
   snd (aux ctxt)
 
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index bd46911c92..ae224cf0d4 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -53,12 +53,13 @@ let is_evaluable env = function
   | EvalVarRef id -> is_evaluable_var env id
 
 let value_of_evaluable_ref env evref u =
+  let open Context.Named.Declaration in
   match evref with
   | EvalConstRef con -> 
     (try constant_value_in env (con,u)
     with NotEvaluableConst IsProj -> 
       raise (Invalid_argument "value_of_evaluable_ref"))
-  | EvalVarRef id -> Option.get (pi2 (lookup_named id env))
+  | EvalVarRef id -> lookup_named id env |> get_value |> Option.get
 
 let evaluable_of_global_reference env = function
   | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
@@ -103,29 +104,29 @@ let destEvalRefU c = match kind_of_term c with
   | Evar ev -> (EvalEvar ev, Univ.Instance.empty)
   | _ -> anomaly (Pp.str "Not an unfoldable reference")
 
-let unsafe_reference_opt_value env sigma eval = 
+let unsafe_reference_opt_value env sigma eval =
   match eval with
   | EvalConst cst ->
     (match (lookup_constant cst env).Declarations.const_body with 
     | Declarations.Def c -> Some (Mod_subst.force_constr c)
     | _ -> None)
   | EvalVar id ->
-      let (_,v,_) = lookup_named id env in
-      v
+      let open Context.Named.Declaration in
+      lookup_named id env |> get_value
   | EvalRel n ->
-      let (_,v,_) = lookup_rel n env in
-      Option.map (lift n) v
+      let open Context.Rel.Declaration in
+      lookup_rel n env |> map_value (lift n) |> get_value
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 let reference_opt_value env sigma eval u = 
   match eval with
   | EvalConst cst -> constant_opt_value_in env (cst,u)
   | EvalVar id ->
-      let (_,v,_) = lookup_named id env in
-      v
+      let open Context.Named.Declaration in
+      lookup_named id env |> get_value
   | EvalRel n ->
-      let (_,v,_) = lookup_rel n env in
-      Option.map (lift n) v
+      let open Context.Rel.Declaration in
+      lookup_rel n env |> map_value (lift n) |> get_value
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 exception NotEvaluable
@@ -258,7 +259,8 @@ let compute_consteval_direct env sigma ref =
     let c',l = whd_betadelta_stack env sigma c in
     match kind_of_term c' with
       | Lambda (id,t,g) when List.is_empty l && not onlyproj ->
-	  srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g
+          let open Context.Rel.Declaration in
+	  srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g
       | Fix fix when not onlyproj ->
 	  (try check_fix_reversibility labs l fix
 	  with Elimconst -> NotAnElimination)
@@ -277,7 +279,8 @@ let compute_consteval_mutual_fix env sigma ref =
     let nargs = List.length l in
     match kind_of_term c' with
       | Lambda (na,t,g) when List.is_empty l ->
-	  srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
+          let open Context.Rel.Declaration in
+	  srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g
       | Fix ((lv,i),(names,_,_)) ->
 	  (* Last known constant wrapping Fix is ref = [labs](Fix l) *)
 	  (match compute_consteval_direct env sigma ref with
@@ -371,7 +374,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs =
 let dummy = mkProp
 let vfx = Id.of_string "_expanded_fix_"
 let vfun = Id.of_string "_eliminator_function_"
-let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)]
+let venv = let open Context.Named.Declaration in
+           val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)]
 
 (* Mark every occurrence of substituted vars (associated to a function)
    as a problem variable: an evar that can be instantiated either by
@@ -534,9 +538,11 @@ let match_eval_ref_value env sigma constr =
   | Const (sp, u) when is_evaluable env (EvalConstRef sp) ->
     Some (constant_value_in env (sp, u))
   | Var id when is_evaluable env (EvalVarRef id) -> 
-    let (_,v,_) = lookup_named id env in v
-  | Rel n -> let (_,v,_) = lookup_rel n env in
-	       Option.map (lift n) v
+     let open Context.Named.Declaration in
+     lookup_named id env |> get_value
+  | Rel n ->
+     let open Context.Rel.Declaration in
+     lookup_rel n env |> map_value (lift n) |> get_value
   | Evar ev -> Evd.existential_opt_value sigma ev
   | _ -> None
 
@@ -601,12 +607,14 @@ let whd_nothing_for_iota env sigma s =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | Rel n ->
+          let open Context.Rel.Declaration in
 	  (match lookup_rel n env with
-	     | (_,Some body,_) -> whrec (lift n body, stack)
+	     | LocalDef (_,body,_) -> whrec (lift n body, stack)
 	     | _ -> s)
       | Var id ->
+          let open Context.Named.Declaration in
 	  (match lookup_named id env with
-	     | (_,Some body,_) -> whrec (body, stack)
+	     | LocalDef (_,body,_) -> whrec (body, stack)
 	     | _ -> s)
       | Evar ev ->
 	(try whrec (Evd.existential_value sigma ev, stack)
@@ -809,7 +817,9 @@ let try_red_product env sigma c =
                         simpfun (Stack.zip (f,stack')))
              | _ -> simpfun (appvect (redrec env f, l)))
       | Cast (c,_,_) -> redrec env c
-      | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
+      | Prod (x,a,b) ->
+          let open Context.Rel.Declaration in
+	  mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b)
       | LetIn (x,a,b,t) -> redrec env (subst1 a t)
       | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
       | Proj (p, c) -> 
@@ -1157,8 +1167,9 @@ let reduce_to_ind_gen allow_product env sigma t =
     match kind_of_term (fst (decompose_app t)) with
       | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l)
       | Prod (n,ty,t') ->
+	  let open Context.Rel.Declaration in
 	  if allow_product then
-	    elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
+	    elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l)
 	  else
 	    errorlabstrm "" (str"Not an inductive definition.")
       | _ ->
@@ -1235,7 +1246,8 @@ let reduce_to_ref_gen allow_product env sigma ref t =
     match kind_of_term c with
       | Prod (n,ty,t') ->
           if allow_product then
-	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+	    let open Context.Rel.Declaration in
+	    elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l)
           else
             error_cannot_recognize ref
       | _ ->
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 3d6196c352..6c62bd08fc 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -16,6 +16,7 @@ open Evd
 open Util
 open Typeclasses_errors
 open Libobject
+open Context.Rel.Declaration
 (*i*)
 
 let typeclasses_unique_solutions = ref false
@@ -180,9 +181,7 @@ let subst_class (subst,cl) =
   let do_subst_con c = Mod_subst.subst_constant subst c
   and do_subst c = Mod_subst.subst_mps subst c
   and do_subst_gr gr = fst (subst_global subst gr) in
-  let do_subst_ctx ctx = List.smartmap
-    (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t))
-    ctx in
+  let do_subst_ctx = List.smartmap (map_constr do_subst) in
   let do_subst_context (grs,ctx) =
     List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
     do_subst_ctx ctx in
@@ -199,15 +198,19 @@ let discharge_class (_,cl) =
   let repl = Lib.replacement_context () in
   let rel_of_variable_context ctx = List.fold_right
     ( fun (n,_,b,t) (ctx', subst) ->
-	let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in
+        let decl = match b with
+                   | None -> LocalAssum (Name n, substn_vars 1 subst t)
+		   | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t)
+	in
 	(decl :: ctx', n :: subst)
     ) ctx ([], []) in
   let discharge_rel_context subst n rel =
     let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in
     let ctx, _ =
       List.fold_right
-	(fun (id, b, t) (ctx, k) ->
-	   (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k)
+	(fun decl (ctx, k) ->
+	   map_constr (substn_vars k subst) decl :: ctx, succ k
+	)
 	rel ([], n)
     in ctx
   in
@@ -217,15 +220,15 @@ let discharge_class (_,cl) =
       | ConstRef cst -> Lib.section_segment_of_constant cst
       | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in
   let discharge_context ctx' subst (grs, ctx) =
-    let grs' = 
-      let newgrs = List.map (fun (_, _, t) -> 
-	match class_of_constr t with
-	| None -> None
-	| Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
-	ctx' 
+    let grs' =
+      let newgrs = List.map (fun decl ->
+			     match decl |> get_type |> class_of_constr with
+			     | None -> None
+			     | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
+			    ctx'
       in
-	List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
-	  @ newgrs
+      List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+      @ newgrs
     in grs', discharge_rel_context subst 1 ctx @ ctx' in
   let cl_impl' = Lib.discharge_global cl.cl_impl in
   if cl_impl' == cl.cl_impl then cl else
@@ -431,11 +434,7 @@ let add_class cl =
  *)
 
 let instance_constructor (cl,u) args =
-  let filter (_, b, _) = match b with
-  | None -> true
-  | Some _ -> false
-  in
-  let lenpars = List.count filter (snd cl.cl_context) in
+  let lenpars = List.count is_local_assum (snd cl.cl_context) in
   let pars = fst (List.chop lenpars args) in
     match cl.cl_impl with
       | IndRef ind -> 
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index fb0c49320f..8be28a6202 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -18,6 +18,7 @@ open Inductive
 open Inductiveops
 open Typeops
 open Arguments_renaming
+open Context.Rel.Declaration
 
 let meta_type evd mv =
   let ty =
@@ -88,16 +89,16 @@ let e_is_correct_arity env evdref c pj ind specif params =
   let rec srec env pt ar =
     let pt' = whd_betadeltaiota env !evdref pt in
     match kind_of_term pt', ar with
-    | Prod (na1,a1,t), (_,None,a1')::ar' ->
+    | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
         if not (Evarconv.e_cumul env evdref a1 a1') then error ();
-        srec (push_rel (na1,None,a1) env) t ar'
+        srec (push_rel (LocalAssum (na1,a1)) env) t ar'
     | Sort s, [] ->
         if not (Sorts.List.mem (Sorts.family s) allowed_sorts)
         then error ()
     | Evar (ev,_), [] ->
         let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in
         evdref := Evd.define ev (mkSort s) evd
-    | _, (_,Some _,_ as d)::ar' ->
+    | _, (LocalDef _ as d)::ar' ->
         srec (push_rel d env) (lift 1 pt') ar'
     | _ ->
         error ()
@@ -229,14 +230,14 @@ let rec execute env evdref cstr =
     | Lambda (name,c1,c2) ->
         let j = execute env evdref c1 in
 	let var = e_type_judgment env evdref j in
-	let env1 = push_rel (name,None,var.utj_val) env in
+	let env1 = push_rel (LocalAssum (name, var.utj_val)) env in
         let j' = execute env1 evdref c2 in
         judge_of_abstraction env1 name var j'
 
     | Prod (name,c1,c2) ->
         let j = execute env evdref c1 in
         let varj = e_type_judgment env evdref j in
-	let env1 = push_rel (name,None,varj.utj_val) env in
+	let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in
         let j' = execute env1 evdref c2 in
         let varj' = e_type_judgment env1 evdref j' in
 	judge_of_product env name varj varj'
@@ -246,7 +247,7 @@ let rec execute env evdref cstr =
         let j2 = execute env evdref c2 in
         let j2 = e_type_judgment env evdref j2 in
         let _ =  e_judge_of_cast env evdref j1 DEFAULTcast j2 in
-        let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+        let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in
         let j3 = execute env1 evdref c3 in
         judge_of_letin env name j1 j2 j3
 
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index b5e882bc4b..6614749d08 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -28,6 +28,7 @@ open Locus
 open Locusops
 open Find_subterm
 open Sigma.Notations
+open Context.Named.Declaration
 
 let keyed_unification = ref (false)
 let _ = Goptions.declare_bool_option {
@@ -58,7 +59,7 @@ let occur_meta_or_undefined_evar evd c =
         | Evar_defined c ->
             occrec c; Array.iter occrec args
         | Evar_empty -> raise Occur)
-    | _ -> iter_constr occrec c
+    | _ -> Constr.iter occrec c
   in try occrec c; false with Occur | Not_found -> true
 
 let occur_meta_evd sigma mv c =
@@ -67,7 +68,7 @@ let occur_meta_evd sigma mv c =
     let c = whd_evar sigma (whd_meta sigma c) in
     match kind_of_term c with
     | Meta mv' when Int.equal mv mv' -> raise Occur
-    | _ -> iter_constr occrec c
+    | _ -> Constr.iter occrec c
   in try occrec c; false with Occur -> true
 
 (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
@@ -75,7 +76,10 @@ let occur_meta_evd sigma mv c =
 
 let abstract_scheme env evd c l lname_typ =
   List.fold_left2
-    (fun (t,evd) (locc,a) (na,_,ta) ->
+    (fun (t,evd) (locc,a) decl ->
+       let open Context.Rel.Declaration in
+       let na = get_name decl in
+       let ta = get_type decl in
        let na = match kind_of_term a with Var id -> Name id | _ -> na in
 (* [occur_meta ta] test removed for support of eelim/ecase but consequences
    are unclear...
@@ -146,7 +150,7 @@ let rec subst_meta_instances bl c =
     | Meta i ->
       let select (j,_,_) = Int.equal i j in
       (try pi2 (List.find select bl) with Not_found -> c)
-    | _ -> map_constr (subst_meta_instances bl) c
+    | _ -> Constr.map (subst_meta_instances bl) c
 
 (** [env] should be the context in which the metas live *)
 
@@ -164,7 +168,7 @@ let pose_all_metas_as_evars env evd t =
         evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
         ev)
   | _ ->
-      map_constr aux t in
+      Constr.map aux t in
   let c = aux t in
   (* side-effect *)
   (!evdref, c)
@@ -568,8 +572,8 @@ let subst_defined_metas_evars (bl,el) c =
     | Evar (evk,args) ->
       let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
       (try substrec (pi3 (List.find select el))
-       with Not_found -> map_constr substrec c)
-    | _ -> map_constr substrec c
+       with Not_found -> Constr.map substrec c)
+    | _ -> Constr.map substrec c
   in try Some (substrec c) with Not_found -> None
 
 let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
@@ -1448,10 +1452,10 @@ let indirectly_dependent c d decls =
        it is needed otherwise, as e.g. when abstracting over "2" in
        "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious
        way to see that the second hypothesis depends indirectly over 2 *)
-    List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls
+    List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls
 
 let indirect_dependency d decls =
-  pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
+  decls  |>  List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d)  |>  List.hd  |>  get_id
 
 let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
   let current_sigma = Sigma.to_evar_map current_sigma in
@@ -1570,7 +1574,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
   in
   let likefirst = clause_with_generic_occurrences occs in
   let mkvarid () = mkVar id in
-  let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
+  let compute_dependency _ d (sign,depdecls) =
+    let hyp = get_id d in
     match occurrences_of_hyp hyp occs with
     | NoOccurrences, InHyp ->
         if indirectly_dependent c d depdecls then
@@ -1607,7 +1612,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
           replace_term_occ_modulo occ test mkvarid concl
     in
     let lastlhyp =
-      if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
+      if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in
     let res = match out test with
     | None -> None
     | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 8b9c2d6c92..7ea9b90635 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -15,6 +15,7 @@ open Environ
 open Inductive
 open Reduction
 open Vm
+open Context.Rel.Declaration
 
 (*******************************************)
 (* Calcul de la forme normal d'un terme    *)
@@ -134,7 +135,7 @@ and nf_whd env whd typ =
       let dom = nf_vtype env (dom p) in
       let name = Name (Id.of_string "x") in
       let vc = body_of_vfun (nb_rel env) (codom p) in
-      let codom = nf_vtype (push_rel (name,None,dom) env) vc  in
+      let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc  in
       mkProd(name,dom,codom)
   | Vfun f -> nf_fun env f typ
   | Vfix(f,None) -> nf_fix env f
@@ -202,11 +203,12 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk =
      in
      nf_univ_args ~nb_univs mk env stk
    | VarKey id ->
-      let (_,_,ty) = lookup_named id env in
+      let open Context.Named.Declaration in
+      let ty = get_type (lookup_named id env) in
       nf_stk env (mkVar id) ty stk
   | RelKey i ->
       let n = (nb_rel env - i) in
-      let (_,_,ty) = lookup_rel n env in
+      let ty = get_type (lookup_rel n env) in
       nf_stk env (mkRel n) (lift n ty) stk
 
 and nf_stk ?from:(from=0) env c t stk  =
@@ -260,7 +262,7 @@ and nf_predicate env ind mip params v pT =
       let vb = body_of_vfun k f in
       let name,dom,codom = decompose_prod env pT in
       let dep,body =
-	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+	nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
   | Vfun f, _ ->
       let k = nb_rel env in
@@ -270,7 +272,7 @@ and nf_predicate env ind mip params v pT =
       let rargs = Array.init n (fun i -> mkRel (n-i)) in
       let params = if Int.equal n 0 then params else Array.map (lift n) params in
       let dom = mkApp(mkIndU ind,Array.append params rargs) in
-      let body = nf_vtype (push_rel (name,None,dom) env) vb in
+      let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type
 
@@ -306,7 +308,7 @@ and nf_fun env f typ =
       Errors.anomaly
         (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
   in
-  let body = nf_val (push_rel (name,None,dom) env) vb codom in
+  let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in
   mkLambda(name,dom,body)
 
 and nf_fix env f =
-- 
cgit v1.2.3


From f46a5686853353f8de733ae7fbd21a3a61977bc7 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 3 Feb 2016 15:32:58 +0100
Subject: Do not give a name to anonymous evars anymore. See bug #4547.

The current solution may not be totally ideal though. We generate names for
anonymous evars on the fly at printing time, based on the Evar_kind data they
are wearing. This means in particular that the printed name of an anonymous
evar may change in the future because some unrelate evar has been solved or
introduced.
---
 pretyping/detyping.ml |   5 ++-
 pretyping/evarutil.ml |   9 +----
 pretyping/evd.ml      | 103 ++++++++++++++++++++++++++++++--------------------
 pretyping/evd.mli     |   4 +-
 4 files changed, 71 insertions(+), 50 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c3877c56e4..0c487ced81 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -518,7 +518,10 @@ let rec detype flags avoid env sigma t =
 	  with Not_found -> isVarId id c in
       let id,l =
         try
-          let id = Evd.evar_ident evk sigma in
+          let id = match Evd.evar_ident evk sigma with
+          | None -> Evd.pr_evar_suggested_name evk sigma
+          | Some id -> id
+          in
           let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in
           let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in
           let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index e23e5a53a7..759e0e4d6d 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -365,14 +365,7 @@ let new_pure_evar_full evd evi =
   (evd, evk)
 
 let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
-  let default_naming =
-    if principal then
-        (* waiting for a more principled approach
-           (unnamed evars, private names?) *)
-        Misctypes.IntroFresh (Names.Id.of_string "tmp_goal")
-      else
-        Misctypes.IntroAnonymous
-  in
+  let default_naming = Misctypes.IntroAnonymous in
   let naming = Option.default default_naming naming in
   let newevk = new_untyped_evar() in
   let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 8be09a7821..0bc688aacf 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -208,15 +208,6 @@ let map_evar_info f evi =
     evar_concl = f evi.evar_concl;
     evar_candidates = Option.map (List.map f) evi.evar_candidates }
 
-let evar_ident_info evi =
-  match evi.evar_source with
-  | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id
-  | _,Evar_kinds.VarInstance id -> id
-  | _,Evar_kinds.GoalEvar -> Id.of_string "Goal"
-  | _ ->
-      let env = reset_with_named_context evi.evar_hyps (Global.env()) in
-      Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous
-
 (* This exception is raised by *.existential_value *)
 exception NotInstantiatedEvar
 
@@ -588,7 +579,7 @@ val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -
 val remove_name_defined : Evar.t -> t -> t
 val rename : Evar.t -> Id.t -> t -> t
 val reassign_name_defined : Evar.t -> Evar.t -> t -> t
-val ident : Evar.t -> t -> Id.t
+val ident : Evar.t -> t -> Id.t option
 val key : Id.t -> t -> Evar.t
 
 end =
@@ -598,21 +589,21 @@ type t = Id.t EvMap.t * existential_key Idmap.t
 
 let empty = (EvMap.empty, Idmap.empty)
 
-let add_name_newly_undefined naming evk evi (evtoid,idtoev) =
+let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) =
   let id = match naming with
-  | Misctypes.IntroAnonymous ->
-      let id = evar_ident_info evi in
-      Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev)
+  | Misctypes.IntroAnonymous -> None
   | Misctypes.IntroIdentifier id ->
-      let id' =
-        Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
-      if not (Names.Id.equal id id') then
-        user_err_loc
-          (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
-      id'
+    if Idmap.mem id idtoev then
+    user_err_loc
+      (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
+    Some id
   | Misctypes.IntroFresh id ->
-      Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
-  (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
+    let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
+    Some id
+  in
+  match id with
+  | None -> names
+  | Some id -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
 
 let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) =
   if EvMap.mem evk evtoid then
@@ -620,25 +611,30 @@ let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) =
   else
     add_name_newly_undefined naming evk evi evar_names
 
-let remove_name_defined evk (evtoid,idtoev) =
-  let id = EvMap.find evk evtoid in
-  (EvMap.remove evk evtoid, Idmap.remove id idtoev)
+let remove_name_defined evk (evtoid, idtoev as names) =
+  let id = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id with
+  | None -> names
+  | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev)
 
 let rename evk id (evtoid, idtoev) =
-  let id' = EvMap.find evk evtoid in
-  if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
-  (EvMap.add evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev))
-
-let reassign_name_defined evk evk' (evtoid,idtoev) =
-  let id = EvMap.find evk evtoid in
-  (EvMap.add evk' id (EvMap.remove evk evtoid),
-   Idmap.add id evk' (Idmap.remove id idtoev))
+  let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id' with
+  | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
+  | Some id' ->
+    if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
+    (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev))
+
+let reassign_name_defined evk evk' (evtoid, idtoev as names) =
+  let id = try Some (EvMap.find evk evtoid) with Not_found -> None in
+  match id with
+  | None -> names (** evk' must not be defined *)
+  | Some id ->
+    (EvMap.add evk' id (EvMap.remove evk evtoid),
+    Idmap.add id evk' (Idmap.remove id idtoev))
 
 let ident evk (evtoid, _) =
-  try EvMap.find evk evtoid
-  with Not_found ->
-    (* Unnamed (non-dependent) evar *)
-    add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
+  try Some (EvMap.find evk evtoid) with Not_found -> None
 
 let key id (_, idtoev) =
   Idmap.find id idtoev
@@ -682,7 +678,7 @@ let add d e i = match i.evar_body with
   let evar_names = EvNames.add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
   { d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
 | Evar_defined _ ->
-  let evar_names = try EvNames.remove_name_defined e d.evar_names with Not_found -> d.evar_names in
+  let evar_names = EvNames.remove_name_defined e d.evar_names in
   { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
 
 let remove d e =
@@ -1706,7 +1702,34 @@ type unsolvability_explanation = SeveralInstancesFound of int
 (**********************************************************)
 (* Pretty-printing *)
 
-let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma)
+let pr_evar_suggested_name evk sigma =
+  let base_id evk' evi =
+  match evar_ident evk' sigma with
+  | Some id -> id
+  | None -> match evi.evar_source with
+  | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id
+  | _,Evar_kinds.VarInstance id -> id
+  | _,Evar_kinds.GoalEvar -> Id.of_string "Goal"
+  | _ ->
+      let env = reset_with_named_context evi.evar_hyps (Global.env()) in
+      Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous
+  in
+  let names = EvMap.mapi base_id sigma.undf_evars in
+  let id = EvMap.find evk names in
+  let fold evk' id' (seen, n) =
+    if seen then (seen, n)
+    else if Evar.equal evk evk' then (true, n)
+    else if Id.equal id id' then (seen, succ n)
+    else (seen, n)
+  in
+  let (_, n) = EvMap.fold fold names (false, 0) in
+  if n = 0 then id else Nameops.add_suffix id (string_of_int (pred n))
+
+let pr_existential_key sigma evk = match evar_ident evk sigma with
+| None ->
+  str "?" ++ pr_id (pr_evar_suggested_name evk sigma)
+| Some id ->
+  str "?" ++ pr_id id
 
 let pr_instance_status (sc,typ) =
   begin match sc with
@@ -1895,7 +1918,7 @@ let pr_evar_list sigma l =
     h 0 (str (string_of_existential ev) ++
       str "==" ++ pr_evar_info evi ++
       (if evi.evar_body == Evar_empty
-       then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}"
+       then str " {" ++  pr_existential_key sigma ev ++ str "}"
        else mt ()))
   in
   h 0 (prlist_with_sep fnl pr l)
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 9cfca02ed8..d2479c1229 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -249,7 +249,7 @@ val evar_source : existential_key -> evar_map -> Evar_kinds.t located
 (** Convenience function. Wrapper around {!find} to recover the source of an
     evar in a given evar map. *)
 
-val evar_ident : existential_key -> evar_map -> Id.t
+val evar_ident : existential_key -> evar_map -> Id.t option
 
 val rename : existential_key -> Id.t -> evar_map -> evar_map
 
@@ -603,6 +603,8 @@ type unsolvability_explanation = SeveralInstancesFound of int
 
 val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
 
+val pr_evar_suggested_name : existential_key -> evar_map -> Id.t
+
 (** {5 Debug pretty-printers} *)
 
 val pr_evar_info : evar_info -> Pp.std_ppcmds
-- 
cgit v1.2.3


From 968dfdb15cc11d48783017b2a91147b25c854ad6 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Tue, 1 Dec 2015 19:45:01 +0100
Subject: Monotonizing the Evarutil module.

Some functions were left in the old paradigm because they are only used by the
unification algorithms, so they are not worthwhile to change for now.
---
 pretyping/cases.ml     |  5 ++++-
 pretyping/evarconv.ml  |  4 +++-
 pretyping/evarsolve.ml | 13 ++++++++---
 pretyping/evarutil.ml  | 60 +++++++++++++++++++++++++++++++-------------------
 pretyping/evarutil.mli | 26 +++++++++++-----------
 pretyping/pretyping.ml | 12 ++++++----
 pretyping/tacred.ml    |  5 ++++-
 7 files changed, 79 insertions(+), 46 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 2cbf3a2650..91bf11eb52 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -28,6 +28,7 @@ open Evarutil
 open Evarsolve
 open Evarconv
 open Evd
+open Sigma.Notations
 
 (* Pattern-matching errors *)
 
@@ -1947,8 +1948,10 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
         let sigma,t = match tycon with
 	| Some t -> sigma,t
 	| None -> 
-	  let sigma, (t, _) = 
+          let sigma = Sigma.Unsafe.of_evar_map sigma in
+          let Sigma ((t, _), sigma, _) =
 	    new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in
+          let sigma = Sigma.to_evar_map sigma in
 	    sigma, t
 	in
         (* First strategy: we build an "inversion" predicate *)
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 99e51330ef..f3ff26876c 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -1007,7 +1007,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
         | None ->
         let evty = set_holes evdref cty subst in
         let instance = Filter.filter_list filter instance in
-        let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
+        let evd = Sigma.Unsafe.of_evar_map !evdref in
+        let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in
+        let evd = Sigma.to_evar_map evd in
         evdref := evd;
         evsref := (fst (destEvar ev),evty)::!evsref;
         ev in
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 0dd0ad2e08..518f4df408 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -19,6 +19,7 @@ open Retyping
 open Reductionops
 open Evarutil
 open Pretype_errors
+open Sigma.Notations
 
 let normalize_evar evd ev =
   match kind_of_term (whd_evar evd (mkEvar ev)) with
@@ -180,7 +181,9 @@ let restrict_evar_key evd evk filter candidates =
       let candidates = match candidates with
       | NoUpdate -> evi.evar_candidates
       | UpdateWith c -> Some c in
-      restrict_evar evd evk filter candidates
+      let sigma = Sigma.Unsafe.of_evar_map evd in
+      let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in
+      (Sigma.to_evar_map sigma, evk)
     end
 
 (* Restrict an applied evar and returns its restriction in the same context *)
@@ -570,7 +573,9 @@ let make_projectable_subst aliases sigma evi args =
  *)
 
 let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env =
-  let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+  let evd = Sigma.to_evar_map evd in
   let t_in_env = whd_evar evd t_in_env in
   let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in
   let ctxt = named_context_of_val sign in
@@ -631,8 +636,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
      ~status:univ_flexible (Some false) env evd (mkSort s) in
     define_evar_from_virtual_equation define_fun env evd src ty_in_env
       ty_t_in_sign sign2 filter2 inst2_in_env in
-  let evd,ev2_in_sign =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (ev2_in_sign, evd, _) =
     new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
+  let evd = Sigma.to_evar_map evd in
   let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
   (evd, ev2_in_sign, ev2_in_env)
 
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index cd5188cd75..2ed557683e 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -19,6 +19,7 @@ open Environ
 open Evd
 open Reductionops
 open Pretype_errors
+open Sigma.Notations
 
 (** Combinators *)
 
@@ -41,7 +42,7 @@ let e_new_global evdref x =
   evd_comb1 (Evd.fresh_global (Global.env())) evdref x
 
 let new_global evd x = 
-  Evd.fresh_global (Global.env()) evd x
+  Sigma.fresh_global (Global.env()) evd x
 
 (****************************************************)
 (* Expanding/testing/exposing existential variables *)
@@ -342,15 +343,18 @@ let push_rel_context_to_named_context env typ =
 let default_source = (Loc.ghost,Evar_kinds.InternalHole)
 
 let restrict_evar evd evk filter candidates =
+  let evd = Sigma.to_evar_map evd in
   let evd, evk' = Evd.restrict evk filter ?candidates evd in
-  Evd.declare_future_goal evk' evd, evk'
+  Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd)
 
 let new_pure_evar_full evd evi =
+  let evd = Sigma.to_evar_map evd in
   let (evd, evk) = Evd.new_evar evd evi in
   let evd = Evd.declare_future_goal evk evd in
-  (evd, evk)
+  Sigma.Unsafe.of_pair (evk, evd)
 
 let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
+  let evd = Sigma.to_evar_map evd in
   let default_naming = Misctypes.IntroAnonymous in
   let naming = Option.default default_naming naming in
   let evi = {
@@ -367,17 +371,17 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca
     if principal then Evd.declare_principal_goal newevk evd
     else Evd.declare_future_goal newevk evd
   in
-  (evd,newevk)
+  Sigma.Unsafe.of_pair (newevk, evd)
 
 let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance =
   assert (not !Flags.debug ||
             List.distinct (ids_of_named_context (named_context_of_val sign)));
-  let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
-  (evd,mkEvar (newevk,Array.of_list instance))
+  let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  Sigma (mkEvar (newevk,Array.of_list instance), evd, p)
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
-let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
   let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
   let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
   let instance =
@@ -386,24 +390,26 @@ let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal t
     | Some filter -> Filter.filter_list filter instance in
   new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
 
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
-  let evd = Sigma.to_evar_map evd in
-  let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
-  Sigma.Unsafe.of_pair (c, sigma)
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  (Sigma.to_evar_map evd, evk)
 
 let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
-  let evd', s = new_sort_variable rigid evd in
-  let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in
-    evd', (e, s)
+  let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in
+  let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
+  Sigma ((e, s), evd', p +> q)
 
 let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
-  let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in
-    evdref := evd';
+  let sigma = Sigma.Unsafe.of_evar_map !evdref in
+  let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in
+  let sigma = Sigma.to_evar_map sigma in
+    evdref := sigma;
     c
 
 let new_Type ?(rigid=Evd.univ_flexible) env evd = 
-  let evd', s = new_sort_variable rigid evd in
-    evd', mkSort s
+  let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in
+  Sigma (mkSort s, sigma, p)
 
 let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
   let evd', s = new_sort_variable rigid !evdref in
@@ -501,7 +507,9 @@ let rec check_and_clear_in_constr env evdref err ids c =
             else
               let origfilter = Evd.evar_filter evi in
               let filter = Evd.Filter.apply_subfilter origfilter filter in
-              let evd,_ = restrict_evar !evdref evk filter None in
+              let evd = Sigma.Unsafe.of_evar_map !evdref in
+              let Sigma (_, evd, _) = restrict_evar evd evk filter None in
+              let evd = Sigma.to_evar_map evd in
               evdref := evd;
 	    (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
 	      let evi = Evd.find !evdref evk in
@@ -708,7 +716,10 @@ let define_pure_evar_as_product evd evk =
   let concl = whd_betadeltaiota evenv evd evi.evar_concl in
   let s = destSort concl in
   let evd1,(dom,u1) =
-    new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+    let evd = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+    (Sigma.to_evar_map evd1, e)
+  in
   let evd2,rng =
     let newenv = push_named (id, None, dom) evenv in
     let src = evar_source evk evd1 in
@@ -719,7 +730,10 @@ let define_pure_evar_as_product evd evk =
       else
 	let status = univ_flexible_alg in
 	let evd3, (rng, srng) =
-	  new_type_evar newenv evd1 status ~src ~filter in
+          let evd1 = Sigma.Unsafe.of_evar_map evd1 in
+          let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
+          (Sigma.to_evar_map evd3, e)
+        in
 	let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
 	let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
 	  evd3, rng
@@ -798,8 +812,8 @@ let define_evar_as_sort env evd (ev,args) =
    any type has type Type. May cause some trouble, but not so far... *)
 
 let judge_of_new_Type evd =
-  let evd', s = new_univ_variable univ_rigid evd in
-    evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
+  let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in
+  Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p)
 
 (* Propagation of constraints through application and abstraction:
    Given a type constraint on a functional term, returns the type
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index d87c7ef8d1..bc4c37a918 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -27,12 +27,12 @@ val new_evar :
   ?principal:bool -> types -> (constr, 'r) Sigma.sigma
 
 val new_pure_evar :
-  named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
   ?candidates:constr list -> ?store:Store.t ->
   ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool -> types -> evar_map * evar
+  ?principal:bool -> types -> (evar, 'r) Sigma.sigma
 
-val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar
+val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma
 
 (** the same with side-effects *)
 val e_new_evar :
@@ -44,23 +44,23 @@ val e_new_evar :
 (** Create a new Type existential variable, as we keep track of 
     them during type-checking and unification. *)
 val new_type_evar :
-  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
   ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
-  evar_map * (constr * sorts)
+  (constr * sorts, 'r) Sigma.sigma
 
 val e_new_type_evar : env -> evar_map ref ->
   ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
   ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts
 
-val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr
+val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma
 val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr
 
-val restrict_evar : evar_map -> existential_key -> Filter.t ->
-  constr list option -> evar_map * existential_key
+val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t ->
+  constr list option -> (existential_key, 'r) Sigma.sigma
 
 (** Polymorphic constants *)
 
-val new_global : evar_map -> Globnames.global_reference -> evar_map * constr
+val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma
 val e_new_global : evar_map ref -> Globnames.global_reference -> constr
 
 (** Create a fresh evar in a context different from its definition context:
@@ -70,11 +70,11 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr
    of [inst] are typed in the occurrence context and their type (seen
    as a telescope) is [sign] *)
 val new_evar_instance :
- named_context_val -> evar_map -> types -> 
-  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> 
+ named_context_val -> 'r Sigma.t -> types -> 
+  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list ->
   ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
   ?principal:bool ->
-  constr list -> evar_map * constr
+  constr list -> (constr, 'r) Sigma.sigma
 
 val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
 
@@ -138,7 +138,7 @@ val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
 
 (** {6 Value/Type constraints} *)
 
-val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment
+val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma
 
 type type_constraint = types option
 type val_constraint = constr option
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 11fba7b941..835dc2f808 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -42,6 +42,7 @@ open Glob_ops
 open Evarconv
 open Pattern
 open Misctypes
+open Sigma.Notations
 
 type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
 type var_map = constr_under_binders Id.Map.t
@@ -444,10 +445,13 @@ let pretype_sort evdref = function
   | GType s -> evd_comb1 judge_of_Type evdref s
 
 let new_type_evar env evdref loc =
-  let e, s = 
-    evd_comb0 (fun evd -> Evarutil.new_type_evar env evd
-      univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
-  in e
+  let sigma = Sigma.Unsafe.of_evar_map !evdref in
+  let Sigma ((e, _), sigma, _) =
+    Evarutil.new_type_evar env sigma
+      univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)
+  in
+  evdref := Sigma.to_evar_map sigma;
+  e
 
 let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
 
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index bd46911c92..085aaf78a1 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -23,6 +23,7 @@ open Reductionops
 open Cbv
 open Patternops
 open Locus
+open Sigma.Notations
 
 (* Errors *)
 
@@ -385,7 +386,9 @@ let substl_with_function subst sigma constr =
     if i <= k + Array.length v then
       match v.(i-k-1) with
       | (fx, Some (min, ref)) ->
-        let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in
+        let sigma = Sigma.Unsafe.of_evar_map !evd in
+        let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in
+        let sigma = Sigma.to_evar_map sigma in
         evd := sigma;
         minargs := Evar.Map.add evk min !minargs;
         lift k (mkEvar (evk, [|fx;ref|]))
-- 
cgit v1.2.3


From 1a8c37ca352c95b4cd530efbbf47f0e7671d1fb3 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 15 Feb 2016 13:31:54 +0100
Subject: Renaming functions in Typing to stick to the standard e_* scheme.

---
 pretyping/coercion.ml | 2 +-
 pretyping/typing.ml   | 8 ++++----
 pretyping/typing.mli  | 6 +++---
 3 files changed, 8 insertions(+), 8 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311bc6..8dae311a9f 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -187,7 +187,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		    (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
 	else Some (fun x -> 
 	  let term = co x in
-	    Typing.solve_evars env evdref term)
+	    Typing.e_solve_evars env evdref term)
       in
 	if isEvar c || isEvar c' then
 	  (* Second-order unification needed. *)
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index fb0c49320f..022c85340a 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -267,7 +267,7 @@ and execute_recdef env evdref (names,lar,vdef) =
 
 and execute_array env evdref = Array.map (execute env evdref)
 
-let check env evdref c t =
+let e_check env evdref c t =
   let env = enrich_env env evdref in
   let j = execute env evdref c in
   if not (Evarconv.e_cumul env evdref j.uj_type t) then
@@ -283,7 +283,7 @@ let unsafe_type_of env evd c =
 
 (* Sort of a type *)
 
-let sort_of env evdref c =
+let e_sort_of env evdref c =
   let env = enrich_env env evdref in
   let j = execute env evdref c in
   let a = e_type_judgment env evdref j in
@@ -310,10 +310,10 @@ let e_type_of ?(refresh=false) env evdref c =
       c
     else j.uj_type
 
-let solve_evars env evdref c =
+let e_solve_evars env evdref c =
   let env = enrich_env env evdref in
   let c = (execute env evdref c).uj_val in
   (* side-effect on evdref *)
   nf_evar !evdref c
 
-let _ = Evarconv.set_solve_evars solve_evars
+let _ = Evarconv.set_solve_evars e_solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index dafd75231a..e524edcca8 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -24,16 +24,16 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types
 val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types
 
 (** Typecheck a type and return its sort *)
-val sort_of : env -> evar_map ref -> types -> sorts
+val e_sort_of : env -> evar_map ref -> types -> sorts
 
 (** Typecheck a term has a given type (assuming the type is OK) *)
-val check   : env -> evar_map ref -> constr -> types -> unit
+val e_check   : env -> evar_map ref -> constr -> types -> unit
 
 (** Returns the instantiated type of a metavariable *)
 val meta_type : evar_map -> metavariable -> types
 
 (** Solve existential variables using typing *)
-val solve_evars : env -> evar_map ref -> constr -> constr
+val e_solve_evars : env -> evar_map ref -> constr -> constr
 
 (** Raise an error message if incorrect elimination for this inductive *)
 (** (first constr is term to match, second is return predicate) *)
-- 
cgit v1.2.3


From 5180ab68819f10949cd41a2458bff877b3ec3204 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 15 Feb 2016 16:45:18 +0100
Subject: Using monotonic types for conversion functions.

---
 pretyping/reductionops.ml  |  2 +-
 pretyping/reductionops.mli |  2 +-
 pretyping/tacred.ml        | 24 ++++++++++++++++--------
 pretyping/tacred.mli       |  3 +--
 4 files changed, 19 insertions(+), 12 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 5e21154a67..a677458dab 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -572,7 +572,7 @@ type state = constr * constr Stack.t
 type  contextual_reduction_function = env ->  evar_map -> constr -> constr
 type  reduction_function =  contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
 
 type  contextual_stack_reduction_function =
     env ->  evar_map -> constr -> constr * constr list
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index e65ab83b29..b38252e971 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -108,7 +108,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr
 type reduction_function = contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
 
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
 
 type contextual_stack_reduction_function =
     env -> evar_map -> constr -> constr * constr list
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 085aaf78a1..be95de873e 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -963,10 +963,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c =
       | _ -> mkApp (app', [| a' |]))
   | _ -> map_constr_with_binders_left_to_right g f acc c
 
-let e_contextually byhead (occs,c) f env sigma t =
+let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
   let (nowhere_except_in,locs) = Locusops.convert_occs occs in
   let maxocc = List.fold_right max locs 0 in
   let pos = ref 1 in
+  let sigma = Sigma.to_evar_map sigma in
+  (** FIXME: we do suspicious things with this evarmap *)
   let evd = ref sigma in
   let rec traverse nested (env,c as envc) t =
     if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t
@@ -985,8 +987,8 @@ let e_contextually byhead (occs,c) f env sigma t =
         (* Skip inner occurrences for stable counting of occurrences *)
         if locs != [] then
           ignore (traverse_below (Some (!pos-1)) envc t);
-	let evm, t = f subst env !evd t in
-	(evd := evm; t)
+	let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in
+	(evd := Sigma.to_evar_map evm; t)
       end
       else
 	traverse_below nested envc t
@@ -1005,11 +1007,15 @@ let e_contextually byhead (occs,c) f env sigma t =
   in
   let t' = traverse None (env,c) t in
   if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
-  !evd, t'
+  Sigma.Unsafe.of_pair (t', !evd)
+  end }
 
 let contextually byhead occs f env sigma t =
-  let f' subst env sigma t = sigma, f subst env sigma t in
-    snd (e_contextually byhead occs f' env sigma t)
+  let f' subst = { e_redfun = begin fun env sigma t ->
+    Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma
+  end } in
+  let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in
+  c
 
 (* linear bindings (following pretty-printer) of the value of name in c.
  * n is the number of the next occurrence of name.
@@ -1128,13 +1134,15 @@ let abstract_scheme env (locc,a) (c, sigma) =
     let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in
       mkLambda (na,ta,c'), sigma'
 
-let pattern_occs loccs_trm env sigma c =
+let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c ->
+  let sigma = Sigma.to_evar_map sigma in
   let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in
   try
     let _ = Typing.unsafe_type_of env sigma abstr_trm in
-      sigma, applist(abstr_trm, List.map snd loccs_trm)
+    Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma)
   with Type_errors.TypeError (env',t) ->
     raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
+  end }
 
 (* Used in several tactics. *)
 
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 6a7248e197..195b21bbf2 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -61,8 +61,7 @@ val unfoldn :
 val fold_commands : constr list ->  reduction_function
 
 (** Pattern *)
-val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> 
-   evar_map * constr
+val pattern_occs : (occurrences * constr) list -> e_reduction_function
 
 (** Rem: Lazy strategies are defined in Reduction *)
 
-- 
cgit v1.2.3


From bd0dc480ec02352b83e335ed2209abcf3d0f89eb Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Fri, 19 Feb 2016 15:56:02 +0100
Subject: Adding location to universes generated by the pretyper.

---
 pretyping/pretyping.ml  | 32 ++++++++++++++++----------------
 pretyping/pretyping.mli |  2 +-
 2 files changed, 17 insertions(+), 17 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 5e8c5beb58..8329de2ee4 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -143,12 +143,12 @@ let interp_universe_level_name evd (loc,s) =
 	  evd, Idmap.find id names
 	with Not_found -> 
 	  if not (is_strict_universe_declarations ()) then
-  	    new_univ_level_variable ~name:s univ_rigid evd
+  	    new_univ_level_variable ~loc ~name:s univ_rigid evd
 	  else user_err_loc (loc, "interp_universe_level_name",
 			     Pp.(str "Undeclared universe: " ++ str s))
 
-let interp_universe evd = function
-  | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
+let interp_universe ?loc evd = function
+  | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in
 	    evd, Univ.Universe.make l
   | l ->
     List.fold_left (fun (evd, u) l -> 
@@ -156,15 +156,15 @@ let interp_universe evd = function
 	(evd', Univ.sup u (Univ.Universe.make l)))
     (evd, Univ.Universe.type0m) l
 
-let interp_universe_level evd = function
-  | None -> new_univ_level_variable univ_rigid evd
+let interp_universe_level loc evd = function
+  | None -> new_univ_level_variable ~loc univ_rigid evd
   | Some (loc,s) -> interp_universe_level_name evd (loc,s)
 
-let interp_sort evd = function
+let interp_sort ?loc evd = function
   | GProp -> evd, Prop Null
   | GSet -> evd, Prop Pos
   | GType n -> 
-    let evd, u = interp_universe evd n in
+    let evd, u = interp_universe ?loc evd n in
       evd, Type u
 
 let interp_elimination_sort = function
@@ -385,11 +385,11 @@ let evar_kind_of_term sigma c =
 (*************************************************************************)
 (* Main pretyping function                                               *)
 
-let interp_universe_level_name evd l =
+let interp_universe_level_name loc evd l =
   match l with
   | GProp -> evd, Univ.Level.prop
   | GSet -> evd, Univ.Level.set
-  | GType s -> interp_universe_level evd s
+  | GType s -> interp_universe_level loc evd s
 
 let pretype_global loc rigid env evd gr us = 
   let evd, instance = 
@@ -404,7 +404,7 @@ let pretype_global loc rigid env evd gr us =
 		       str "Universe instance should have length " ++ int len)
        else
 	 let evd, l' = List.fold_left (fun (evd, univs) l -> 
-	    let evd, l = interp_universe_level_name evd l in
+	    let evd, l = interp_universe_level_name loc evd l in
 	      (evd, l :: univs)) (evd, []) l
 	 in
 	 if List.exists (fun l -> Univ.Level.is_prop l) l' then
@@ -413,7 +413,7 @@ let pretype_global loc rigid env evd gr us =
 		   str " universe instances must be greater or equal to Set.");
 	 evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
   in
-    Evd.fresh_global ~rigid ?names:instance env evd gr
+    Evd.fresh_global ~loc ~rigid ?names:instance env evd gr
 
 let pretype_ref loc evdref env ref us =
   match ref with
@@ -431,17 +431,17 @@ let pretype_ref loc evdref env ref us =
     let ty = Typing.unsafe_type_of env evd c in
       make_judge c ty
 
-let judge_of_Type evd s =
-  let evd, s = interp_universe evd s in
+let judge_of_Type loc evd s =
+  let evd, s = interp_universe ~loc evd s in
   let judge = 
     { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
   in
     evd, judge
 
-let pretype_sort evdref = function
+let pretype_sort loc evdref = function
   | GProp -> judge_of_prop
   | GSet -> judge_of_set
-  | GType s -> evd_comb1 judge_of_Type evdref s
+  | GType s -> evd_comb1 (judge_of_Type loc) evdref s
 
 let new_type_evar env evdref loc =
   let sigma = Sigma.Unsafe.of_evar_map !evdref in
@@ -598,7 +598,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
   | GSort (loc,s) ->
-    let j = pretype_sort evdref s in
+    let j = pretype_sort loc evdref s in
       inh_conv_coerce_to_tycon loc env evdref j tycon
 
   | GApp (loc,f,args) ->
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index bfb4e7325e..40745ed097 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -148,7 +148,7 @@ val ise_pretype_gen :
 
 (** To embed constr in glob_constr *)
 
-val interp_sort : evar_map -> glob_sort -> evar_map * sorts
+val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts
 val interp_elimination_sort : glob_sort -> sorts_family
 
 val genarg_interp_hook :
-- 
cgit v1.2.3


From 5bca0e81c46c1cc6427f939263670996f570dbcf Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 2 Feb 2016 15:47:23 +0100
Subject: Fix part of bug #4533: respect declared global transparency of
 projections in unification.ml

---
 pretyping/unification.ml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 6cb1bc7028..55210d067e 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -481,7 +481,8 @@ let key_of env b flags f =
       Id.Pred.mem id (fst flags.modulo_delta) ->
     Some (IsKey (VarKey id))
   | Proj (p, c) when Projection.unfolded p
-      || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) ->
+    || (is_transparent env (ConstKey (Projection.constant p)) &&
+       (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) ->
     Some (IsProj (p, c))
   | _ -> None
   
-- 
cgit v1.2.3


From 4fcd7fd68986246adb666ed46d066fcf0355bf09 Mon Sep 17 00:00:00 2001
From: Hugo Herbelin
Date: Sat, 20 Feb 2016 14:32:40 +0100
Subject: Slightly contracting code of evarconv.ml.

---
 pretyping/evarconv.ml | 17 +++++++----------
 1 file changed, 7 insertions(+), 10 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 0a45ae9fd8..0ccc5b654b 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -322,25 +322,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
      Note: incomplete heuristic... *)
   let ground_test =
     if is_ground_term evd term1 && is_ground_term evd term2 then (
-      let evd, e = 
+      let e =
 	try
 	  let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts)
 	    env evd term1 term2 
 	  in
-	    if b then evd, None
-	    else evd, Some (ConversionFailed (env,term1,term2))
-	with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e)
+	    if b then Success evd
+	    else UnifFailure (evd, ConversionFailed (env,term1,term2))
+	with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e)
       in
 	match e with
-	| None -> Some (evd, e)
-	| Some e -> 
-	  if is_ground_env evd env then Some (evd, Some e)
-	  else None)
+	| UnifFailure (evd, e) when not (is_ground_env evd env) -> None
+	| _ -> Some e)
     else None
   in
   match ground_test with
-    | Some (evd, None) -> Success evd
-    | Some (evd, Some e) -> UnifFailure (evd,e)
+    | Some result -> result
     | None ->
 	(* Until pattern-unification is used consistently, use nohdbeta to not
 	   destroy beta-redexes that can be used for 1st-order unification *)
-- 
cgit v1.2.3


From a5ae3b2856e6cc6683652a0abb5a84b9787527c0 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 9 Mar 2016 15:15:38 +0100
Subject: Fix strategy of Keyed Unification

Try first to find a keyed subterm without conversion/betaiota on open
terms (that is the usual strategy of rewrite), if this fails, try with full
conversion, incuding betaiota. This makes the test-suite pass again,
retaining efficiency in the most common cases.
---
 pretyping/unification.ml | 30 +++++++++++++++++++++++++++---
 1 file changed, 27 insertions(+), 3 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 55210d067e..31fd711bf9 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -356,6 +356,22 @@ let set_no_delta_flags flags = {
   resolve_evars = flags.resolve_evars
 }
 
+(* For the first phase of keyed unification, restrict
+  to conversion (including beta-iota) only on closed terms *)
+let set_no_delta_open_core_flags flags = { flags with
+  modulo_delta = empty_transparent_state;
+  modulo_betaiota = false;
+}
+
+let set_no_delta_open_flags flags = {
+  core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags;
+  merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags;
+  subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags;
+  allow_K_in_toplevel_higher_order_unification =
+      flags.allow_K_in_toplevel_higher_order_unification;
+  resolve_evars = flags.resolve_evars
+}
+
 (* Default flag for the "simple apply" version of unification of a *)
 (* type against a type (e.g. apply) *)
 (* We set only the flags available at the time the new "apply" extended *)
@@ -1790,17 +1806,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t =
         let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
         let flags =
           if occur_meta_or_existential op || !keyed_unification then
+	    (* This is up to delta for subterms w/o metas ... *)
             flags
           else
             (* up to Nov 2014, unification was bypassed on evar/meta-free terms;
                now it is called in a minimalistic way, at least to possibly
                unify pre-existing non frozen evars of the goal or of the
                pattern *)
-            set_no_delta_flags flags in
+          set_no_delta_flags flags in
+	let t' = (strip_outer_cast op,t) in
         let (evd',cl) =
           try
-	    (* This is up to delta for subterms w/o metas ... *)
-	    w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
+  	    if is_keyed_unification () then
+    	      try (* First try finding a subterm w/o conversion on open terms *)
+	        let flags = set_no_delta_open_flags flags in
+		w_unify_to_subterm env evd ~flags t'
+	      with e ->
+		(* If this fails, try with full conversion *)
+		w_unify_to_subterm env evd ~flags t'
+	    else w_unify_to_subterm env evd ~flags t'
 	  with PretypeError (env,_,NoOccurrenceFound _) when
               allow_K ||
                 (* w_unify_to_subterm does not go through evars, so
-- 
cgit v1.2.3


From 4341f37cf3c51ed82c23f05846c8e6e8823d3cd6 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 10 Mar 2016 19:02:16 +0100
Subject: Primitive projections: protect kernel from erroneous definitions.

E.g., Inductive foo := mkFoo { bla : foo } allowed to define recursive
records with eta for which conversion is incomplete.

- Eta-conversion only applies to BiFinite inductives
- Finiteness information is now checked by the kernel (the constructor types
  must be strictly non recursive for BiFinite declarations).
---
 pretyping/evarconv.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 637a9e50e0..690b974be5 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -854,7 +854,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
 and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 =
   let mib = lookup_mind (fst ind) env in
     match mib.Declarations.mind_record with
-    | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> 
+    | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> 
       let pars = mib.Declarations.mind_nparams in
 	(try 
 	   let l1' = Stack.tail pars sk1 in
-- 
cgit v1.2.3


From fc7264feee8ee62aeda8af4d756deb009f29fc2b Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 14 Mar 2016 11:13:21 +0100
Subject: Try eta-expansion of records only on non-recursive ones

---
 pretyping/unification.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 03a700e176..15e8022af0 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -629,7 +629,7 @@ let is_eta_constructor_app env ts f l1 term =
   | Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
     let mib = lookup_mind (fst ind) env in
       (match mib.Declarations.mind_record with
-      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
+      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite &&
           Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
 	(** Check that the other term is neutral *)
 	is_neutral env ts term
-- 
cgit v1.2.3


From 8f5ca2a6100eb243d2a9842a13e02b793ee0aea1 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 14 Mar 2016 11:13:21 +0100
Subject: Try eta-expansion of records only on non-recursive ones

---
 pretyping/unification.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 31fd711bf9..9b6e856b80 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -609,7 +609,7 @@ let is_eta_constructor_app env ts f l1 term =
   | Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
     let mib = lookup_mind (fst ind) env in
       (match mib.Declarations.mind_record with
-      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
+      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite &&
           Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
 	(** Check that the other term is neutral *)
 	is_neutral env ts term
-- 
cgit v1.2.3


From bfce815bd1fa2c603141661b209a864c67ae1dbf Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 16 Mar 2016 18:00:25 +0100
Subject: Fix incorrect behavior of CS resolution

Due to a change in pretyping, using cast annotations as typing
constraints, the canonical structure problems given to the unification
could contain non-evar-normalized terms, hence we force
evar normalization where necessary to ensure the same CS solutions
can be found. Here the dependency test is fooled by an erasable
dependency, and the following resolution needs a independent codomain
for pop b to be well-scoped.
---
 pretyping/evarconv.ml | 1 +
 1 file changed, 1 insertion(+)

(limited to 'pretyping')

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 690b974be5..b8d92b9be7 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -138,6 +138,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) =
     try
       match kind_of_term t2 with
 	Prod (_,a,b) -> (* assert (l2=[]); *)
+	  let _, a, b = destProd (Evarutil.nf_evar sigma t2) in
       	  if dependent (mkRel 1) b then raise Not_found
 	  else lookup_canonical_conversion (proji, Prod_cs),
 	    (Stack.append_app [|a;pop b|] Stack.empty)
-- 
cgit v1.2.3


From 82b371aceb1ef6b1e15bdace2cf142e65724a3c6 Mon Sep 17 00:00:00 2001
From: Maxime Dénès
Date: Thu, 17 Mar 2016 17:53:25 +0100
Subject: Fix #4623: set tactic too weak with universes (regression)

The regression was introduced by efa1c32a4d178, which replaced
unification by conversion when looking for more occurrences of a
subterm. The conversion function called was not the right one, as it
was not inferring constraints.
---
 pretyping/unification.ml | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 9b6e856b80..cd0bbfa300 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1532,8 +1532,9 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
     | e when Errors.noncritical e -> raise (NotUnifiable None) in
   let merge_fun c1 c2 =
     match c1, c2 with
-    | Some (evd,c1,_) as x, Some (_,c2,_) ->
-      if is_conv env sigma c1 c2 then x else raise (NotUnifiable None)
+    | Some (evd,c1,x), Some (_,c2,_) ->
+      let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in
+      if b then Some (evd, c1, x) else raise (NotUnifiable None)
     | Some _, None -> c1
     | None, Some _ -> c2
     | None, None -> None in
-- 
cgit v1.2.3


From ea4e09c26747fa9c49882580a72139fe748a0d64 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 19:38:36 +0100
Subject: Moving Proofview to pretyping/.

---
 pretyping/pretyping.mllib |    1 +
 pretyping/proofview.ml    | 1204 +++++++++++++++++++++++++++++++++++++++++++++
 pretyping/proofview.mli   |  586 ++++++++++++++++++++++
 3 files changed, 1791 insertions(+)
 create mode 100644 pretyping/proofview.ml
 create mode 100644 pretyping/proofview.mli

(limited to 'pretyping')

diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index b59589bda2..5dfdd0379a 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -21,6 +21,7 @@ Constr_matching
 Tacred
 Typeclasses_errors
 Typeclasses
+Proofview
 Classops
 Program
 Coercion
diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml
new file mode 100644
index 0000000000..20be02e76d
--- /dev/null
+++ b/pretyping/proofview.ml
@@ -0,0 +1,1204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+
+(** This files defines the basic mechanism of proofs: the [proofview]
+    type is the state which tactics manipulate (a global state for
+    existential variables, together with the list of goals), and the type
+    ['a tactic] is the (abstract) type of tactics modifying the proof
+    state and returning a value of type ['a]. *)
+
+open Pp
+open Util
+open Proofview_monad
+open Sigma.Notations
+open Context.Named.Declaration
+
+(** Main state of tactics *)
+type proofview = Proofview_monad.proofview
+
+type entry = (Term.constr * Term.types) list
+
+(** Returns a stylised view of a proofview for use by, for instance,
+    ide-s. *)
+(* spiwack: the type of [proofview] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: returns the list of focused goals together with
+   the [evar_map] context. *)
+let proofview p =
+  p.comb , p.solution
+
+let compact el ({ solution } as pv) =
+  let nf = Evarutil.nf_evar solution in
+  let size = Evd.fold (fun _ _ i -> i+1) solution 0 in
+  let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in
+  let pruned_solution = Evd.drop_all_defined solution in
+  let apply_subst_einfo _ ei =
+    Evd.({ ei with
+       evar_concl =  nf ei.evar_concl;
+       evar_hyps = Environ.map_named_val nf ei.evar_hyps;
+       evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in
+  let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in
+  let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in
+  msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
+  new_el, { pv with solution = new_solution; }
+
+
+(** {6 Starting and querying a proof view} *)
+
+type telescope =
+  | TNil of Evd.evar_map
+  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
+
+let dependent_init =
+  (* Goals are created with a store which marks them as unresolvable
+     for type classes. *)
+  let store = Typeclasses.set_resolvable Evd.Store.empty false in
+  (* Goals don't have a source location. *)
+  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+  (* Main routine *)
+  let rec aux = function
+  | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] }
+  | TCons (env, sigma, typ, t) ->
+    let sigma = Sigma.Unsafe.of_evar_map sigma in
+    let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in
+    let sigma = Sigma.to_evar_map sigma in
+    let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
+    let (gl, _) = Term.destEvar econstr in
+    let entry = (econstr, typ) :: ret in
+    entry, { solution = sol; comb = gl :: comb; shelf = [] }
+  in
+  fun t ->
+    let entry, v = aux t in
+    (* The created goal are not to be shelved. *)
+    let solution = Evd.reset_future_goals v.solution in
+    entry, { v with solution }
+
+let init =
+  let rec aux sigma = function
+    | [] -> TNil sigma
+    | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l))
+  in
+  fun sigma l -> dependent_init (aux sigma l)
+
+let initial_goals initial = initial
+
+let finished = function
+  | {comb = []} -> true
+  | _  -> false
+
+let return { solution=defs } = defs
+
+let return_constr { solution = defs } c = Evarutil.nf_evar defs c
+
+let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry)
+
+
+(** {6 Focusing commands} *)
+
+(** A [focus_context] represents the part of the proof view which has
+    been removed by a focusing action, it can be used to unfocus later
+    on. *)
+(* First component is a reverse list of the goals which come before
+   and second component is the list of the goals which go after (in
+   the expected order). *)
+type focus_context = Evar.t list * Evar.t list
+
+
+(** Returns a stylised view of a focus_context for use by, for
+    instance, ide-s. *)
+(* spiwack: the type of [focus_context] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: the goals in the context, as a "zipper" (the first
+   list is in reversed order). *)
+let focus_context f = f
+
+(** This (internal) function extracts a sublist between two indices,
+    and returns this sublist together with its context: if it returns
+    [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
+    original list.  The focused list has lenght [j-i-1] and contains
+    the goals from number [i] to number [j] (both included) the first
+    goal of the list being numbered [1].  [focus_sublist i j l] raises
+    [IndexOutOfRange] if [i > length l], or [j > length l] or [j <
+    i]. *)
+let focus_sublist i j l =
+  let (left,sub_right) = CList.goto (i-1) l in
+  let (sub, right) = 
+    try CList.chop (j-i+1) sub_right
+    with Failure _ -> raise CList.IndexOutOfRange
+  in
+  (sub, (left,right))
+
+(** Inverse operation to the previous one. *)
+let unfocus_sublist (left,right) s =
+  CList.rev_append left (s@right)
+
+
+(** [focus i j] focuses a proofview on the goals from index [i] to
+    index [j] (inclusive, goals are indexed from [1]). I.e. goals
+    number [i] to [j] become the only focused goals of the returned
+    proofview.  It returns the focused proofview, and a context for
+    the focus stack. *)
+let focus i j sp =
+  let (new_comb, context) = focus_sublist i j sp.comb in
+  ( { sp with comb = new_comb } , context )
+
+
+(** [advance sigma g] returns [Some g'] if [g'] is undefined and is
+    the current avatar of [g] (for instance [g] was changed by [clear]
+    into [g']). It returns [None] if [g] has been (partially)
+    solved. *)
+(* spiwack: [advance] is probably performance critical, and the good
+   behaviour of its definition may depend sensitively to the actual
+   definition of [Evd.find]. Currently, [Evd.find] starts looking for
+   a value in the heap of undefined variable, which is small. Hence in
+   the most common case, where [advance] is applied to an unsolved
+   goal ([advance] is used to figure if a side effect has modified the
+   goal) it terminates quickly. *)
+let rec advance sigma g =
+  let open Evd in
+  let evi = Evd.find sigma g in
+  match evi.evar_body with
+  | Evar_empty -> Some g
+  | Evar_defined v ->
+      if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then
+        let (e,_) = Term.destEvar v in
+        advance sigma e
+      else
+        None
+
+(** [undefined defs l] is the list of goals in [l] which are still
+    unsolved (after advancing cleared goals). *)
+let undefined defs l = CList.map_filter (advance defs) l
+
+(** Unfocuses a proofview with respect to a context. *)
+let unfocus c sp =
+  { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) }
+
+
+(** {6 The tactic monad} *)
+
+(** - Tactics are objects which apply a transformation to all the
+    subgoals of the current view at the same time. By opposition to
+    the old vision of applying it to a single goal. It allows tactics
+    such as [shelve_unifiable], tactics to reorder the focused goals,
+    or global automation tactic for dependent subgoals (instantiating
+    an evar has influences on the other goals of the proof in
+    progress, not being able to take that into account causes the
+    current eauto tactic to fail on some instances where it could
+    succeed).  Another benefit is that it is possible to write tactics
+    that can be executed even if there are no focused goals.
+    - Tactics form a monad ['a tactic], in a sense a tactic can be
+    seen as a function (without argument) which returns a value of
+    type 'a and modifies the environment (in our case: the view).
+    Tactics of course have arguments, but these are given at the
+    meta-level as OCaml functions.  Most tactics in the sense we are
+    used to return [()], that is no really interesting values. But
+    some might pass information around.  The tactics seen in Coq's
+    Ltac are (for now at least) only [unit tactic], the return values
+    are kept for the OCaml toolkit.  The operation or the monad are
+    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
+    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
+    (which is a specialized bind on unit-returning tactics).
+    - Tactics have support for full-backtracking. Tactics can be seen
+    having multiple success: if after returning the first success a
+    failure is encountered, the tactic can backtrack and use a second
+    success if available. The state is backtracked to its previous
+    value, except the non-logical state defined in the {!NonLogical}
+    module below.
+*)
+(* spiwack: as far as I'm aware this doesn't really relate to
+   F. Kirchner and C. Muñoz. *)
+
+module Proof = Logical
+
+(** type of tactics:
+
+   tactics can
+   - access the environment,
+   - report unsafe status, shelved goals and given up goals
+   - access and change the current [proofview]
+   - backtrack on previous changes of the proofview *)
+type +'a tactic = 'a Proof.t
+
+(** Applies a tactic to the current proofview. *)
+let apply env t sp =
+  let open Logic_monad in
+  let ans = Proof.repr (Proof.run t false (sp,env)) in
+  let ans = Logic_monad.NonLogical.run ans in
+  match ans with
+  | Nil (e, info) -> iraise (TacticFailure e, info)
+  | Cons ((r, (state, _), status, info), _) ->
+    let (status, gaveup) = status in
+    let status = (status, state.shelf, gaveup) in
+    let state = { state with shelf = [] } in
+    r, state, status, Trace.to_tree info
+
+
+
+(** {7 Monadic primitives} *)
+
+(** Unit of the tactic monad. *)
+let tclUNIT = Proof.return
+
+(** Bind operation of the tactic monad. *)
+let tclBIND = Proof.(>>=)
+
+(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation,
+    it's a specialized "bind". *)
+let tclTHEN = Proof.(>>)
+
+(** [tclIGNORE t] has the same operational content as [t], but drops
+    the returned value. *)
+let tclIGNORE = Proof.ignore
+
+module Monad = Proof
+
+
+
+(** {7 Failure and backtracking} *)
+
+
+(** [tclZERO e] fails with exception [e]. It has no success. *)
+let tclZERO ?info e =
+  let info = match info with
+  | None -> Exninfo.null
+  | Some info -> info
+  in
+  Proof.zero (e, info)
+
+(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
+    the successes of [t1] have been depleted and it failed with [e],
+    then it behaves as [t2 e]. In other words, [tclOR] inserts a
+    backtracking point. *)
+let tclOR = Proof.plus
+
+(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
+    success or [t2 e] if [t1] fails with [e]. It is analogous to
+    [try/with] handler of exception in that it is not a backtracking
+    point. *)
+let tclORELSE t1 t2 =
+  let open Logic_monad in
+  let open Proof in
+  split t1 >>= function
+    | Nil e -> t2 e
+    | Cons (a,t1') -> plus (return a) t1'
+
+(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
+    succeeds at least once then it behaves as [tclBIND a s] otherwise,
+    if [a] fails with [e], then it behaves as [f e]. *)
+let tclIFCATCH a s f =
+  let open Logic_monad in
+  let open Proof in
+  split a >>= function
+    | Nil e -> f e
+    | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x'))
+
+(** [tclONCE t] behave like [t] except it has at most one success:
+    [tclONCE t] stops after the first success of [t]. If [t] fails
+    with [e], [tclONCE t] also fails with [e]. *)
+let tclONCE = Proof.once
+
+exception MoreThanOneSuccess
+let _ = Errors.register_handler begin function
+  | MoreThanOneSuccess -> Errors.error "This tactic has more than one success."
+  | _ -> raise Errors.Unhandled
+end
+
+(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
+    success. Otherwise it fails. The tactic [t] is run until its first
+    success, then a failure with exception [e] is simulated. It [t]
+    yields another success, then [tclEXACTLY_ONCE e t] fails with
+    [MoreThanOneSuccess] (it is a user error). Otherwise,
+    [tclEXACTLY_ONCE e t] succeeds with the first success of
+    [t]. Notice that the choice of [e] is relevant, as the presence of
+    further successes may depend on [e] (see {!tclOR}). *)
+let tclEXACTLY_ONCE e t =
+  let open Logic_monad in
+  let open Proof in
+  split t >>= function
+    | Nil (e, info) -> tclZERO ~info e
+    | Cons (x,k) ->
+        Proof.split (k (e, Exninfo.null)) >>= function
+          | Nil _ -> tclUNIT x
+          | _ -> tclZERO MoreThanOneSuccess
+
+
+(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *)
+type 'a case =
+| Fail of iexn
+| Next of 'a * (iexn -> 'a tactic)
+let tclCASE t =
+  let open Logic_monad in
+  let map = function
+  | Nil e -> Fail e
+  | Cons (x, t) -> Next (x, t)
+  in
+  Proof.map map (Proof.split t)
+
+let tclBREAK = Proof.break
+
+
+
+(** {7 Focusing tactics} *)
+
+exception NoSuchGoals of int
+
+(* This hook returns a string to be appended to the usual message.
+   Primarily used to add a suggestion about the right bullet to use to
+   focus the next goal, if applicable. *)
+let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ())
+let set_nosuchgoals_hook f = nosuchgoals_hook := f
+
+
+
+(* This uses the hook above *)
+let _ = Errors.register_handler begin function
+  | NoSuchGoals n ->
+    let suffix = !nosuchgoals_hook n in
+    Errors.errorlabstrm ""
+      (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix)
+  | _ -> raise Errors.Unhandled
+end
+
+(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where
+    only the goals numbered [i] to [j] are focused (the rest of the goals
+    is restored at the end of the tactic). If the range [i]-[j] is not
+    valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *)
+let tclFOCUS_gen nosuchgoal i j t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  try
+    let (focused,context) = focus i j initial in
+    Pv.set focused >>
+    t >>= fun result ->
+    Pv.modify (fun next -> unfocus context next) >>
+    return result
+  with CList.IndexOutOfRange -> nosuchgoal
+
+let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t
+let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t
+
+(** Like {!tclFOCUS} but selects a single goal by name. *)
+let tclFOCUSID id t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  try
+    let ev = Evd.evar_key id initial.solution in
+    try
+      let n = CList.index Evar.equal ev initial.comb in
+      (* goal is already under focus *)
+      let (focused,context) = focus n n initial in
+      Pv.set focused >>
+        t >>= fun result ->
+      Pv.modify (fun next -> unfocus context next) >>
+        return result
+    with Not_found ->
+      (* otherwise, save current focus and work purely on the shelve *)
+      Comb.set [ev] >>
+        t >>= fun result ->
+      Comb.set initial.comb  >>
+        return result
+  with Not_found -> tclZERO (NoSuchGoals 1)
+
+(** {7 Dispatching on goals} *)
+
+exception SizeMismatch of int*int
+let _ = Errors.register_handler begin function
+  | SizeMismatch (i,_) ->
+      let open Pp in
+      let errmsg =
+        str"Incorrect number of goals" ++ spc() ++
+        str"(expected "++int i++str(String.plural i " tactic") ++ str")."
+      in
+      Errors.errorlabstrm "" errmsg
+  | _ -> raise Errors.Unhandled
+end
+
+(** A variant of [Monad.List.iter] where we iter over the focused list
+    of goals. The argument tactic is executed in a focus comprising
+    only of the current goal, a goal which has been solved by side
+    effect is skipped. The generated subgoals are concatenated in
+    order.  *)
+let iter_goal i =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Proof.List.fold_left begin fun (subgoals as cur) goal ->
+    Solution.get >>= fun step ->
+    match advance step goal with
+    | None -> return cur
+    | Some goal ->
+        Comb.set [goal] >>
+        i goal >>
+        Proof.map (fun comb -> comb :: subgoals) Comb.get
+  end [] initial >>= fun subgoals ->
+  Solution.get >>= fun evd ->
+  Comb.set CList.(undefined evd (flatten (rev subgoals)))
+
+(** A variant of [Monad.List.fold_left2] where the first list is the
+    list of focused goals. The argument tactic is executed in a focus
+    comprising only of the current goal, a goal which has been solved
+    by side effect is skipped. The generated subgoals are concatenated
+    in order. *)
+let fold_left2_goal i s l =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let err =
+    return () >>= fun () -> (* Delay the computation of list lengths. *)
+    tclZERO (SizeMismatch (CList.length initial.comb,CList.length l))
+  in 
+  Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a ->
+    Solution.get >>= fun step ->
+    match advance step goal with
+    | None -> return cur
+    | Some goal ->
+        Comb.set [goal] >>
+        i goal a r >>= fun r ->
+        Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get
+  end (s,[]) initial.comb l >>= fun (r,subgoals) ->
+  Solution.get >>= fun evd ->
+  Comb.set CList.(undefined evd (flatten (rev subgoals))) >>
+  return r
+
+(** Dispatch tacticals are used to apply a different tactic to each
+    goal under focus. They come in two flavours: [tclDISPATCH] takes a
+    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
+    takes a list of ['a tactic] and returns an ['a list tactic].
+
+    They both work by applying each of the tactic in a focus
+    restricted to the corresponding goal (starting with the first
+    goal). In the case of [tclDISPATCHL], the tactic returns a list of
+    the same size as the argument list (of tactics), each element
+    being the result of the tactic executed in the corresponding goal.
+
+    When the length of the tactic list is not the number of goal,
+    raises [SizeMismatch (g,t)] where [g] is the number of available
+    goals, and [t] the number of tactics passed.
+
+    [tclDISPATCHGEN join tacs] generalises both functions as the
+    successive results of [tacs] are stored in reverse order in a
+    list, and [join] is used to convert the result into the expected
+    form. *)
+let tclDISPATCHGEN0 join tacs =
+  match tacs with
+  | [] ->
+      begin 
+        let open Proof in
+        Comb.get >>= function
+        | [] -> tclUNIT (join [])
+        | comb -> tclZERO (SizeMismatch (CList.length comb,0))
+      end
+  | [tac] ->
+      begin
+        let open Proof in
+        Pv.get >>= function
+        | { comb=[goal] ; solution } ->
+            begin match advance solution goal with
+            | None -> tclUNIT (join [])
+            | Some _ -> Proof.map (fun res -> join [res]) tac
+            end
+        | {comb} -> tclZERO (SizeMismatch(CList.length comb,1))
+      end
+  | _ ->
+      let iter _ t cur = Proof.map (fun y -> y :: cur) t in
+      let ans = fold_left2_goal iter [] tacs in
+      Proof.map join ans
+
+let tclDISPATCHGEN join tacs =
+  let branch t = InfoL.tag (Info.DBranch) t in
+  let tacs = CList.map branch tacs in
+  InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs)
+
+let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs
+
+let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs
+
+
+(** [extend_to_list startxs rx endxs l] builds a list
+    [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises
+    [SizeMismatch] if [startxs@endxs] is already longer than [l]. *)
+let extend_to_list startxs rx endxs l =
+  (* spiwack: I use [l] essentially as a natural number *)
+  let rec duplicate acc = function
+    | [] -> acc
+    | _::rest -> duplicate (rx::acc) rest
+  in
+  let rec tail to_match rest =
+    match rest, to_match with
+    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
+    | _::rest , _::to_match -> tail to_match rest
+    | _ , [] -> duplicate endxs rest
+  in
+  let rec copy pref rest =
+    match rest,pref with
+    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
+    | _::rest, a::pref -> a::(copy pref rest)
+    | _ , [] -> tail endxs rest
+  in
+  copy startxs l
+
+(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
+    tactic is "repeated" enough time such that every goal has a tactic
+    assigned to it ([b] is the list of tactics applied to the first
+    goals, [e] to the last goals, and [r] is applied to every goal in
+    between). *)
+let tclEXTEND tacs1 rtac tacs2 =
+  let open Proof in
+  Comb.get >>= fun comb ->
+  try
+    let tacs = extend_to_list tacs1 rtac tacs2 comb in
+    tclDISPATCH tacs
+  with SizeMismatch _ ->
+    tclZERO (SizeMismatch(
+      CList.length comb,
+      (CList.length tacs1)+(CList.length tacs2)))
+(* spiwack: failure occurs only when the number of goals is too
+   small. Hence we can assume that [rtac] is replicated 0 times for
+   any error message. *)
+
+(** [tclEXTEND [] tac []]. *)
+let tclINDEPENDENT tac =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  match initial.comb with
+  | [] -> tclUNIT ()
+  | [_] -> tac
+  | _ ->
+      let tac = InfoL.tag (Info.DBranch) tac in
+      InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac))
+
+
+
+(** {7 Goal manipulation} *)
+
+(** Shelves all the goals under focus. *)
+let shelve =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Comb.set [] >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >>
+  Shelf.modify (fun gls -> gls @ initial)
+
+
+(** [contained_in_info e evi] checks whether the evar [e] appears in
+    the hypotheses, the conclusion or the body of the evar_info
+    [evi]. Note: since we want to use it on goals, the body is actually
+    supposed to be empty. *)
+let contained_in_info sigma e evi =
+  Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
+
+(** [depends_on sigma src tgt] checks whether the goal [src] appears
+    as an existential variable in the definition of the goal [tgt] in
+    [sigma]. *)
+let depends_on sigma src tgt =
+  let evi = Evd.find sigma tgt in
+  contained_in_info sigma src evi
+
+(** [unifiable sigma g l] checks whether [g] appears in another
+    subgoal of [l]. The list [l] may contain [g], but it does not
+    affect the result. *)
+let unifiable sigma g l =
+  CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l
+
+(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)]
+    where [u] is composed of the unifiable goals, i.e. the goals on
+    whose definition other goals of [l] depend, and [n] are the
+    non-unifiable goals. *)
+let partition_unifiable sigma l =
+  CList.partition (fun g -> unifiable sigma g l) l
+
+(** Shelves the unifiable goals under focus, i.e. the goals which
+    appear in other goals under focus (the unfocused goals are not
+    considered). *)
+let shelve_unifiable =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let (u,n) = partition_unifiable initial.solution initial.comb in
+  Comb.set n >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >>
+  Shelf.modify (fun gls -> gls @ u)
+
+(** [guard_no_unifiable] returns the list of unifiable goals if some
+    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
+let guard_no_unifiable =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let (u,n) = partition_unifiable initial.solution initial.comb in
+  match u with
+  | [] -> tclUNIT None
+  | gls ->
+      let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in
+      let l = CList.map (fun id -> Names.Name id) l in
+      tclUNIT (Some l)
+
+(** [unshelve l p] adds all the goals in [l] at the end of the focused
+    goals of p *)
+let unshelve l p =
+  (* advance the goals in case of clear *)
+  let l = undefined p.solution l in
+  { p with comb = p.comb@l }
+
+let with_shelf tac =
+  let open Proof in
+  Pv.get >>= fun pv ->
+  let { shelf; solution } = pv in
+  Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >>
+  tac >>= fun ans ->
+  Pv.get >>= fun npv ->
+  let { shelf = gls; solution = sigma } = npv in
+  let gls' = Evd.future_goals sigma in
+  let fgoals = Evd.future_goals solution in
+  let pgoal = Evd.principal_future_goal solution in
+  let sigma = Evd.restore_future_goals sigma fgoals pgoal in
+  Pv.set { npv with shelf; solution = sigma } >>
+  tclUNIT (CList.rev_append gls' gls, ans)
+
+(** [goodmod p m] computes the representative of [p] modulo [m] in the
+    interval [[0,m-1]].*)
+let goodmod p m =
+  let p' = p mod m in
+  (* if [n] is negative [n mod l] is negative of absolute value less
+     than [l], so [(n mod l)+l] is the representative of [n] in the
+     interval [[0,l-1]].*)
+  if p' < 0 then p'+m else p'
+
+let cycle n =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >>
+  Comb.modify begin fun initial ->
+    let l = CList.length initial in
+    let n' = goodmod n l in
+    let (front,rear) = CList.chop n' initial in
+    rear@front
+  end
+
+let swap i j =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >>
+  Comb.modify begin fun initial ->
+    let l = CList.length initial in
+    let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in
+    let i = goodmod i l and j = goodmod j l in
+    CList.map_i begin fun k x ->
+      match k with
+      | k when Int.equal k i -> CList.nth initial j
+      | k when Int.equal k j -> CList.nth initial i
+      | _ -> x
+    end 0 initial
+  end
+
+let revgoals =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >>
+  Comb.modify CList.rev
+
+let numgoals =
+  let open Proof in
+  Comb.get >>= fun comb ->
+  return (CList.length comb)
+
+
+
+(** {7 Access primitives} *)
+
+let tclEVARMAP = Solution.get
+
+let tclENV = Env.get
+
+
+
+(** {7 Put-like primitives} *)
+
+
+let emit_side_effects eff x =
+  { x with solution = Evd.emit_side_effects eff x.solution }
+
+let tclEFFECTS eff =
+  let open Proof in
+  return () >>= fun () -> (* The Global.env should be taken at exec time *)
+  Env.set (Global.env ()) >>
+  Pv.modify (fun initial -> emit_side_effects eff initial)
+
+let mark_as_unsafe = Status.put false
+
+(** Gives up on the goal under focus. Reports an unsafe status. Proofs
+    with given up goals cannot be closed. *)
+let give_up =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Comb.set [] >>
+  mark_as_unsafe >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >>
+  Giveup.put initial
+
+
+
+(** {7 Control primitives} *)
+
+
+module Progress = struct
+
+  let eq_constr = Evarutil.eq_constr_univs_test
+
+  (** equality function on hypothesis contexts *)
+  let eq_named_context_val sigma1 sigma2 ctx1 ctx2 =
+    let open Environ in
+    let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in
+    let eq_named_declaration d1 d2 =
+      match d1, d2 with
+      | LocalAssum (i1,t1), LocalAssum (i2,t2) ->
+         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2
+      | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) ->
+         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2
+         && eq_constr sigma1 sigma2 t1 t2
+      | _ ->
+         false
+    in List.equal eq_named_declaration c1 c2
+
+  let eq_evar_body sigma1 sigma2 b1 b2 =
+    let open Evd in
+    match b1, b2 with
+    | Evar_empty, Evar_empty -> true
+    | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2
+    | _ -> false
+
+  let eq_evar_info sigma1 sigma2 ei1 ei2 =
+    let open Evd in
+    eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl &&
+    eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) &&
+    eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body
+
+  (** Equality function on goals *)
+  let goal_equal evars1 gl1 evars2 gl2 =
+    let evi1 = Evd.find evars1 gl1 in
+    let evi2 = Evd.find evars2 gl2 in
+    eq_evar_info evars1 evars2 evi1 evi2
+
+end
+
+let tclPROGRESS t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  t >>= fun res ->
+  Pv.get >>= fun final ->
+  (* [*_test] test absence of progress. [quick_test] is approximate
+     whereas [exhaustive_test] is complete. *)
+  let quick_test =
+    initial.solution == final.solution && initial.comb == final.comb
+  in
+  let exhaustive_test =
+    Util.List.for_all2eq begin fun i f ->
+      Progress.goal_equal initial.solution i final.solution f
+    end initial.comb final.comb
+  in
+  let test =
+    quick_test || exhaustive_test
+  in
+  if not test then
+    tclUNIT res
+  else
+    tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
+
+exception Timeout
+let _ = Errors.register_handler begin function
+  | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
+  | _ -> Pervasives.raise Errors.Unhandled
+end
+
+let tclTIMEOUT n t =
+  let open Proof in
+  (* spiwack: as one of the monad is a continuation passing monad, it
+     doesn't force the computation to be threaded inside the underlying
+     (IO) monad. Hence I force it myself by asking for the evaluation of
+     a dummy value first, lest [timeout] be called when everything has
+     already been computed. *)
+  let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in
+  Proof.get >>= fun initial ->
+  Proof.current >>= fun envvar ->
+  Proof.lift begin
+    Logic_monad.NonLogical.catch
+      begin
+        let open Logic_monad.NonLogical in
+        timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
+        match r with
+        | Logic_monad.Nil e -> return (Util.Inr e)
+        | Logic_monad.Cons (r, _) -> return (Util.Inl r)
+      end
+      begin let open Logic_monad.NonLogical in function (e, info) ->
+        match e with
+        | Logic_monad.Timeout -> return (Util.Inr (Timeout, info))
+        | Logic_monad.TacticFailure e ->
+          return (Util.Inr (e, info))
+        | e -> Logic_monad.NonLogical.raise ~info e
+      end
+  end >>= function
+    | Util.Inl (res,s,m,i) ->
+        Proof.set s >>
+        Proof.put m >>
+        Proof.update (fun _ -> i) >>
+        return res
+    | Util.Inr (e, info) -> tclZERO ~info e
+
+let tclTIME s t =
+  let pr_time t1 t2 n msg =
+    let msg =
+      if n = 0 then
+        str msg
+      else
+        str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking")
+    in
+    msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++
+             System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in
+  let rec aux n t =
+    let open Proof in
+    tclUNIT () >>= fun () ->
+    let tstart = System.get_time() in
+    Proof.split t >>= let open Logic_monad in function
+    | Nil (e, info) ->
+      begin
+        let tend = System.get_time() in
+        pr_time tstart tend n "failure";
+        tclZERO ~info e
+      end
+    | Cons (x,k) ->
+        let tend = System.get_time() in
+        pr_time tstart tend n "success";
+        tclOR (tclUNIT x) (fun e -> aux (n+1) (k e))
+  in aux 0 t
+
+
+
+(** {7 Unsafe primitives} *)
+
+module Unsafe = struct
+
+  let tclEVARS evd =
+    Pv.modify (fun ps -> { ps with solution = evd })
+
+  let tclNEWGOALS gls =
+    Pv.modify begin fun step ->
+      let gls = undefined step.solution gls in
+      { step with comb = step.comb @ gls }
+    end
+
+  let tclGETGOALS = Comb.get
+
+  let tclSETGOALS = Comb.set
+
+  let tclEVARSADVANCE evd =
+    Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb })
+
+  let tclEVARUNIVCONTEXT ctx = 
+    Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx })
+
+  let reset_future_goals p =
+    { p with solution = Evd.reset_future_goals p.solution }
+
+  let mark_as_goal evd content =
+    let info = Evd.find evd content in
+    let info =
+      { info with Evd.evar_source = match info.Evd.evar_source with
+      | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
+      | loc,_ -> loc,Evar_kinds.GoalEvar }
+    in
+    let info = Typeclasses.mark_unresolvable info in
+    Evd.add evd content info
+
+  let advance = advance
+
+end
+
+module UnsafeRepr = Proof.Unsafe
+
+let (>>=) = tclBIND
+let (<*>) = tclTHEN
+let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
+
+(** {6 Goal-dependent tactics} *)
+
+let goal_env evars gl =
+  let evi = Evd.find evars gl in
+  Evd.evar_filtered_env evi
+
+let goal_nf_evar sigma gl =
+  let evi = Evd.find sigma gl in
+  let evi = Evarutil.nf_evar_info sigma evi in
+  let sigma = Evd.add sigma gl evi in
+  (gl, sigma)
+
+let goal_extra evars gl =
+  let evi = Evd.find evars gl in
+  evi.Evd.evar_extra
+
+
+let catchable_exception = function
+  | Logic_monad.Exception _ -> false
+  | e -> Errors.noncritical e
+
+
+module Goal = struct
+
+  type ('a, 'r) t = {
+    env : Environ.env;
+    sigma : Evd.evar_map;
+    concl : Term.constr ;
+    self : Evar.t ; (* for compatibility with old-style definitions *)
+  }
+
+  type ('a, 'b) enter =
+    { enter : 'r. ('a, 'r) t -> 'b }
+
+  let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t)
+
+  let env { env=env } = env
+  let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma
+  let hyps { env=env } = Environ.named_context env
+  let concl { concl=concl } = concl
+  let extra { sigma=sigma; self=self } = goal_extra sigma self
+
+  let raw_concl { concl=concl } = concl
+
+
+  let gmake_with info env sigma goal = 
+    { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ;
+      sigma = sigma ;
+      concl = Evd.evar_concl info ;
+      self = goal }
+
+  let nf_gmake env sigma goal =
+    let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in
+    let sigma = Evd.add sigma goal info in
+    gmake_with info env sigma goal , sigma
+
+  let nf_enter f =
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try
+        let (gl, sigma) = nf_gmake env sigma goal in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl))
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let normalize { self } =
+    Env.get >>= fun env ->
+    tclEVARMAP >>= fun sigma ->
+    let (gl,sigma) = nf_gmake env sigma self in
+    tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl)
+
+  let gmake env sigma goal =
+    let info = Evd.find sigma goal in
+    gmake_with info env sigma goal
+
+  let enter f =
+    let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try f (gmake env sigma goal)
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  type ('a, 'b) s_enter =
+    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
+
+  let s_enter f =
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try
+        let gl = gmake env sigma goal in
+        let Sigma (tac, sigma, _) = f.s_enter gl in
+        let sigma = Sigma.to_evar_map sigma in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let nf_s_enter f =
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try
+        let (gl, sigma) = nf_gmake env sigma goal in
+        let Sigma (tac, sigma, _) = f.s_enter gl in
+        let sigma = Sigma.to_evar_map sigma in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let goals =
+    Pv.get >>= fun step ->
+    let sigma = step.solution in
+    let map goal =
+      match advance sigma goal with
+      | None -> None (** ppedrot: Is this check really necessary? *)
+      | Some goal ->
+        let gl =
+          Env.get >>= fun env ->
+          tclEVARMAP >>= fun sigma ->
+          tclUNIT (gmake env sigma goal)
+        in
+        Some gl
+    in
+    tclUNIT (CList.map_filter map step.comb)
+
+  (* compatibility *)
+  let goal { self=self } = self
+
+  let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t)
+
+end
+
+
+
+(** {6 Trace} *)
+
+module Trace = struct
+
+  let record_info_trace = InfoL.record_trace
+
+  let log m = InfoL.leaf (Info.Msg m)
+  let name_tactic m t = InfoL.tag (Info.Tactic m) t
+
+  let pr_info ?(lvl=0) info =
+    assert (lvl >= 0);
+    Info.(print (collapse lvl info))
+
+end
+
+
+
+(** {6 Non-logical state} *)
+
+module NonLogical = Logic_monad.NonLogical
+
+let tclLIFT = Proof.lift
+
+let tclCHECKINTERRUPT =
+   tclLIFT (NonLogical.make Control.check_for_interrupt)
+
+
+
+
+
+(*** Compatibility layer with <= 8.2 tactics ***)
+module V82 = struct
+  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
+
+  let tactic tac =
+    (* spiwack: we ignore the dependencies between goals here,
+       expectingly preserving the semantics of <= 8.2 tactics *)
+    (* spiwack: convenience notations, waiting for ocaml 3.12 *)
+    let open Proof in
+    Pv.get >>= fun ps ->
+    try
+      let tac gl evd = 
+        let glsigma  =
+          tac { Evd.it = gl ; sigma = evd; }  in
+        let sigma = glsigma.Evd.sigma in
+        let g = glsigma.Evd.it in
+        ( g, sigma )
+      in
+        (* Old style tactics expect the goals normalized with respect to evars. *)
+      let (initgoals,initevd) =
+        Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution
+      in
+      let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in
+      let sgs = CList.flatten goalss in
+      let sgs = undefined evd sgs in
+      InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >>
+      Pv.set { ps with solution = evd; comb = sgs; }
+    with e when catchable_exception e ->
+      let (e, info) = Errors.push e in
+      tclZERO ~info e
+
+
+  (* normalises the evars in the goals, and stores the result in
+     solution. *)
+  let nf_evar_goals =
+    Pv.modify begin fun ps ->
+    let map g s = goal_nf_evar s g in
+    let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in
+    { ps with solution = evd; comb = goals; }
+    end
+      
+  let has_unresolved_evar pv =
+    Evd.has_undefined pv.solution
+
+  (* Main function in the implementation of Grab Existential Variables.*)
+  let grab pv =
+    let undef = Evd.undefined_map pv.solution in
+    let goals = CList.rev_map fst (Evar.Map.bindings undef) in
+    { pv with comb = goals }
+      
+    
+
+  (* Returns the open goals of the proofview together with the evar_map to 
+     interpret them. *)
+  let goals { comb = comb ; solution = solution; } =
+   { Evd.it = comb ; sigma = solution }
+
+  let top_goals initial { solution=solution; } =
+    let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in
+    { Evd.it = goals ; sigma=solution; }
+
+  let top_evars initial =
+    let evars_of_initial (c,_) =
+      Evar.Set.elements (Evd.evars_of_term c)
+    in
+    CList.flatten (CList.map evars_of_initial initial)
+
+  let of_tactic t gls =
+    try
+      let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in
+      let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in
+      { Evd.sigma = final.solution ; it = final.comb }
+    with Logic_monad.TacticFailure e as src ->
+      let (_, info) = Errors.push src in
+      iraise (e, info)
+
+  let put_status = Status.put
+
+  let catchable_exception = catchable_exception
+
+  let wrap_exceptions f =
+    try f ()
+    with e when catchable_exception e ->
+      let (e, info) = Errors.push e in tclZERO ~info e
+
+end
+
+(** {7 Notations} *)
+
+module Notations = struct
+  let (>>=) = tclBIND
+  let (<*>) = tclTHEN
+  let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
+  type ('a, 'b) enter = ('a, 'b) Goal.enter =
+    { enter : 'r. ('a, 'r) Goal.t -> 'b }
+  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
+end
diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli
new file mode 100644
index 0000000000..6bc2e9a0ed
--- /dev/null
+++ b/pretyping/proofview.mli
@@ -0,0 +1,586 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This files defines the basic mechanism of proofs: the [proofview]
+    type is the state which tactics manipulate (a global state for
+    existential variables, together with the list of goals), and the type
+    ['a tactic] is the (abstract) type of tactics modifying the proof
+    state and returning a value of type ['a]. *)
+
+open Util
+open Term
+
+(** Main state of tactics *)
+type proofview
+
+(** Returns a stylised view of a proofview for use by, for instance,
+    ide-s. *)
+(* spiwack: the type of [proofview] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: returns the list of focused goals together with
+   the [evar_map] context. *)
+val proofview : proofview -> Goal.goal list * Evd.evar_map
+
+
+(** {6 Starting and querying a proof view} *)
+
+(** Abstract representation of the initial goals of a proof. *)
+type entry
+
+(** Optimize memory consumption *)
+val compact : entry -> proofview -> entry * proofview
+
+(** Initialises a proofview, the main argument is a list of
+    environments (including a [named_context] which are used as
+    hypotheses) pair with conclusion types, creating accordingly many
+    initial goals. Because a proof does not necessarily starts in an
+    empty [evar_map] (indeed a proof can be triggered by an incomplete
+    pretyping), [init] takes an additional argument to represent the
+    initial [evar_map]. *)
+val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview
+
+(** A [telescope] is a list of environment and conclusion like in
+    {!init}, except that each element may depend on the previous
+    goals. The telescope passes the goals in the form of a
+    [Term.constr] which represents the goal as an [evar]. The
+    [evar_map] is threaded in state passing style. *)
+type telescope =
+  | TNil of Evd.evar_map
+  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
+
+(** Like {!init}, but goals are allowed to be dependent on one
+    another. Dependencies between goals is represented with the type
+    [telescope] instead of [list]. Note that the first [evar_map] of
+    the telescope plays the role of the [evar_map] argument in
+    [init]. *)
+val dependent_init  : telescope -> entry * proofview
+
+(** [finished pv] is [true] if and only if [pv] is complete. That is,
+    if it has an empty list of focused goals. There could still be
+    unsolved subgoaled, but they would then be out of focus. *)
+val finished : proofview -> bool
+
+(** Returns the current [evar] state. *)
+val return : proofview -> Evd.evar_map
+
+val partial_proof : entry -> proofview -> constr list
+val initial_goals : entry -> (constr * types) list
+
+
+
+(** {6 Focusing commands} *)
+
+(** A [focus_context] represents the part of the proof view which has
+    been removed by a focusing action, it can be used to unfocus later
+    on. *)
+type focus_context
+
+(** Returns a stylised view of a focus_context for use by, for
+    instance, ide-s. *)
+(* spiwack: the type of [focus_context] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: the goals in the context, as a "zipper" (the first
+   list is in reversed order). *)
+val focus_context : focus_context -> Goal.goal list * Goal.goal list
+
+(** [focus i j] focuses a proofview on the goals from index [i] to
+    index [j] (inclusive, goals are indexed from [1]). I.e. goals
+    number [i] to [j] become the only focused goals of the returned
+    proofview.  It returns the focused proofview, and a context for
+    the focus stack. *)
+val focus : int -> int -> proofview -> proofview * focus_context
+
+(** Unfocuses a proofview with respect to a context. *)
+val unfocus : focus_context -> proofview -> proofview
+
+
+(** {6 The tactic monad} *)
+
+(** - Tactics are objects which apply a transformation to all the
+    subgoals of the current view at the same time. By opposition to
+    the old vision of applying it to a single goal. It allows tactics
+    such as [shelve_unifiable], tactics to reorder the focused goals,
+    or global automation tactic for dependent subgoals (instantiating
+    an evar has influences on the other goals of the proof in
+    progress, not being able to take that into account causes the
+    current eauto tactic to fail on some instances where it could
+    succeed).  Another benefit is that it is possible to write tactics
+    that can be executed even if there are no focused goals.
+    - Tactics form a monad ['a tactic], in a sense a tactic can be
+    seen as a function (without argument) which returns a value of
+    type 'a and modifies the environment (in our case: the view).
+    Tactics of course have arguments, but these are given at the
+    meta-level as OCaml functions.  Most tactics in the sense we are
+    used to return [()], that is no really interesting values. But
+    some might pass information around.  The tactics seen in Coq's
+    Ltac are (for now at least) only [unit tactic], the return values
+    are kept for the OCaml toolkit.  The operation or the monad are
+    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
+    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
+    (which is a specialized bind on unit-returning tactics).
+    - Tactics have support for full-backtracking. Tactics can be seen
+    having multiple success: if after returning the first success a
+    failure is encountered, the tactic can backtrack and use a second
+    success if available. The state is backtracked to its previous
+    value, except the non-logical state defined in the {!NonLogical}
+    module below.
+*)
+
+
+(** The abstract type of tactics *)
+type +'a tactic 
+
+(** Applies a tactic to the current proofview. Returns a tuple
+    [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv]
+    is the updated proofview, [b] a boolean which is [true] if the
+    tactic has not done any action considered unsafe (such as
+    admitting a lemma), [sh] is the list of goals which have been
+    shelved by the tactic, and [gu] the list of goals on which the
+    tactic has given up. In case of multiple success the first one is
+    selected. If there is no success, fails with
+    {!Logic_monad.TacticFailure}*)
+val apply : Environ.env -> 'a tactic -> proofview -> 'a
+                                                   * proofview
+                                                   * (bool*Goal.goal list*Goal.goal list)
+                                                   * Proofview_monad.Info.tree
+
+(** {7 Monadic primitives} *)
+
+(** Unit of the tactic monad. *)
+val tclUNIT : 'a -> 'a tactic
+ 
+(** Bind operation of the tactic monad. *)
+val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+
+(** Interprets the ";" (semicolon) of Ltac. As a monadic operation,
+    it's a specialized "bind". *)
+val tclTHEN : unit tactic -> 'a tactic -> 'a tactic
+
+(** [tclIGNORE t] has the same operational content as [t], but drops
+    the returned value. *)
+val tclIGNORE : 'a tactic -> unit tactic
+
+(** Generic monadic combinators for tactics. *)
+module Monad : Monad.S with type +'a t = 'a tactic
+
+(** {7 Failure and backtracking} *)
+
+(** [tclZERO e] fails with exception [e]. It has no success. *)
+val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic
+
+(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
+    the successes of [t1] have been depleted and it failed with [e],
+    then it behaves as [t2 e]. In other words, [tclOR] inserts a
+    backtracking point. *)
+val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
+
+(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
+    success or [t2 e] if [t1] fails with [e]. It is analogous to
+    [try/with] handler of exception in that it is not a backtracking
+    point. *)
+val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
+
+(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
+    succeeds at least once then it behaves as [tclBIND a s] otherwise,
+    if [a] fails with [e], then it behaves as [f e]. *)
+val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic
+
+(** [tclONCE t] behave like [t] except it has at most one success:
+    [tclONCE t] stops after the first success of [t]. If [t] fails
+    with [e], [tclONCE t] also fails with [e]. *)
+val tclONCE : 'a tactic -> 'a tactic
+
+(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
+    success. Otherwise it fails. The tactic [t] is run until its first
+    success, then a failure with exception [e] is simulated. It [t]
+    yields another success, then [tclEXACTLY_ONCE e t] fails with
+    [MoreThanOneSuccess] (it is a user error). Otherwise,
+    [tclEXACTLY_ONCE e t] succeeds with the first success of
+    [t]. Notice that the choice of [e] is relevant, as the presence of
+    further successes may depend on [e] (see {!tclOR}). *)
+exception MoreThanOneSuccess
+val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic
+
+(** [tclCASE t] splits [t] into its first success and a
+    continuation. It is the most general primitive to control
+    backtracking. *)
+type 'a case =
+  | Fail of iexn
+  | Next of 'a * (iexn -> 'a tactic)
+val tclCASE : 'a tactic -> 'a case tactic
+
+(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of
+    stopping after the first success, it succeeds like [t] until a
+    failure with an exception [e] such that [p e = Some e'] is raised. At
+    which point it drops the remaining successes, failing with [e'].
+    [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *)
+val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
+
+
+(** {7 Focusing tactics} *)
+
+(** [tclFOCUS i j t] applies [t] after focusing on the goals number
+    [i] to [j] (see {!focus}). The rest of the goals is restored after
+    the tactic action. If the specified range doesn't correspond to
+    existing goals, fails with [NoSuchGoals] (a user error). this
+    exception is caught at toplevel with a default message + a hook
+    message that can be customized by [set_nosuchgoals_hook] below.
+    This hook is used to add a suggestion about bullets when
+    applicable. *)
+exception NoSuchGoals of int
+val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit
+
+val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
+
+(** [tclFOCUSID x t] applies [t] on a (single) focused goal like
+    {!tclFOCUS}. The goal is found by its name rather than its
+    number.*)
+val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic
+
+(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the
+    specified range doesn't correspond to existing goals, behaves like
+    [tclUNIT ()] instead of failing. *)
+val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic
+
+
+(** {7 Dispatching on goals} *)
+
+(** Dispatch tacticals are used to apply a different tactic to each
+    goal under focus. They come in two flavours: [tclDISPATCH] takes a
+    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
+    takes a list of ['a tactic] and returns an ['a list tactic].
+
+    They both work by applying each of the tactic in a focus
+    restricted to the corresponding goal (starting with the first
+    goal). In the case of [tclDISPATCHL], the tactic returns a list of
+    the same size as the argument list (of tactics), each element
+    being the result of the tactic executed in the corresponding goal.
+
+    When the length of the tactic list is not the number of goal,
+    raises [SizeMismatch (g,t)] where [g] is the number of available
+    goals, and [t] the number of tactics passed. *)
+exception SizeMismatch of int*int
+val tclDISPATCH : unit tactic list -> unit tactic
+val tclDISPATCHL : 'a tactic list -> 'a list tactic
+
+(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
+    tactic is "repeated" enough time such that every goal has a tactic
+    assigned to it ([b] is the list of tactics applied to the first
+    goals, [e] to the last goals, and [r] is applied to every goal in
+    between). *)
+val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic
+
+(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from
+    the first one to the last one. Backtracking in one goal is
+    independent of backtracking in another. It is equivalent to
+    [tclEXTEND [] tac []]. *)
+val tclINDEPENDENT : unit tactic -> unit tactic
+
+
+(** {7 Goal manipulation} *)
+
+(** Shelves all the goals under focus. The goals are placed on the
+    shelf for later use (or being solved by side-effects). *)
+val shelve : unit tactic
+
+(** Shelves the unifiable goals under focus, i.e. the goals which
+    appear in other goals under focus (the unfocused goals are not
+    considered). *)
+val shelve_unifiable : unit tactic
+
+(** [guard_no_unifiable] returns the list of unifiable goals if some
+    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
+val guard_no_unifiable : Names.Name.t list option tactic
+
+(** [unshelve l p] adds all the goals in [l] at the end of the focused
+    goals of p *)
+val unshelve : Goal.goal list -> proofview -> proofview
+
+(** [with_shelf tac] executes [tac] and returns its result together with the set
+    of goals shelved by [tac]. The current shelf is unchanged. *)
+val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic
+
+(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
+    is negative, then it puts the [n] last goals first.*)
+val cycle : int -> unit tactic
+
+(** [swap i j] swaps the position of goals number [i] and [j]
+    (negative numbers can be used to address goals from the end. Goals
+    are indexed from [1]. For simplicity index [0] corresponds to goal
+    [1] as well, rather than raising an error. *)
+val swap : int -> int -> unit tactic
+
+(** [revgoals] reverses the list of focused goals. *)
+val revgoals : unit tactic
+
+(** [numgoals] returns the number of goals under focus. *)
+val numgoals : int tactic
+
+
+(** {7 Access primitives} *)
+
+(** [tclEVARMAP] doesn't affect the proof, it returns the current
+    [evar_map]. *)
+val tclEVARMAP : Evd.evar_map tactic
+
+(** [tclENV] doesn't affect the proof, it returns the current
+    environment. It is not the environment of a particular goal,
+    rather the "global" environment of the proof. The goal-wise
+    environment is obtained via {!Proofview.Goal.env}. *)
+val tclENV : Environ.env tactic
+
+
+(** {7 Put-like primitives} *)
+
+(** [tclEFFECTS eff] add the effects [eff] to the current state. *)
+val tclEFFECTS : Safe_typing.private_constants -> unit tactic
+
+(** [mark_as_unsafe] declares the current tactic is unsafe. *)
+val mark_as_unsafe : unit tactic
+
+(** Gives up on the goal under focus. Reports an unsafe status. Proofs
+    with given up goals cannot be closed. *)
+val give_up : unit tactic
+
+
+(** {7 Control primitives} *)
+
+(** [tclPROGRESS t] checks the state of the proof after [t]. It it is
+    identical to the state before, then [tclePROGRESS t] fails, otherwise
+    it succeeds like [t]. *)
+val tclPROGRESS : 'a tactic -> 'a tactic
+
+(** Checks for interrupts *)
+val tclCHECKINTERRUPT : unit tactic
+
+exception Timeout
+(** [tclTIMEOUT n t] can have only one success.
+    In case of timeout if fails with [tclZERO Timeout]. *)
+val tclTIMEOUT : int -> 'a tactic -> 'a tactic
+
+(** [tclTIME s t] displays time for each atomic call to t, using s as an
+    identifying annotation if present *)
+val tclTIME : string option -> 'a tactic -> 'a tactic
+
+(** {7 Unsafe primitives} *)
+
+(** The primitives in the [Unsafe] module should be avoided as much as
+    possible, since they can make the proof state inconsistent. They are
+    nevertheless helpful, in particular when interfacing the pretyping and
+    the proof engine. *)
+module Unsafe : sig
+
+  (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If
+      [sigma] has new unresolved [evar]-s they will not appear as
+      goal. If goals have been solved in [sigma] they will still
+      appear as unsolved goals. *)
+  val tclEVARS : Evd.evar_map -> unit tactic
+    
+  (** Like {!tclEVARS} but also checks whether goals have been solved. *)
+  val tclEVARSADVANCE : Evd.evar_map -> unit tactic
+
+  (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently
+      being proved, appending them to the list of focused goals. If a
+      goal is already solved, it is not added. *)
+  val tclNEWGOALS : Goal.goal list -> unit tactic
+
+  (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a
+      goal is already solved, it is not set. *)
+  val tclSETGOALS : Goal.goal list -> unit tactic
+
+  (** [tclGETGOALS] returns the list of goals under focus. *)
+  val tclGETGOALS : Goal.goal list tactic
+
+  (** Sets the evar universe context. *)
+  val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic
+
+  (** Clears the future goals store in the proof view. *)
+  val reset_future_goals : proofview -> proofview
+
+  (** Give an evar the status of a goal (changes its source location
+      and makes it unresolvable for type classes. *)
+  val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map
+
+  (** [advance sigma g] returns [Some g'] if [g'] is undefined and is
+      the current avatar of [g] (for instance [g] was changed by [clear]
+      into [g']). It returns [None] if [g] has been (partially)
+      solved. *)
+  val advance : Evd.evar_map -> Evar.t -> Evar.t option
+end
+
+(** This module gives access to the innards of the monad. Its use is
+    restricted to very specific cases. *)
+module UnsafeRepr :
+sig
+  type state = Proofview_monad.Logical.Unsafe.state
+  val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t
+  val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic
+end
+
+(** {6 Goal-dependent tactics} *)
+
+module Goal : sig
+
+  (** Type of goals.
+
+      The first parameter type is a phantom argument indicating whether the data
+      contained in the goal has been normalized w.r.t. the current sigma. If it
+      is the case, it is flagged [ `NF ]. You may still access the un-normalized
+      data using {!assume} if you known you do not rely on the assumption of
+      being normalized, at your own risk.
+
+      The second parameter is a stage indicating where the goal belongs. See
+      module {!Sigma}.
+  *)
+  type ('a, 'r) t
+
+  (** Assume that you do not need the goal to be normalized. *)
+  val assume : ('a, 'r) t -> ([ `NF ], 'r) t
+
+  (** Normalises the argument goal. *)
+  val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic
+
+  (** [concl], [hyps], [env] and [sigma] given a goal [gl] return
+      respectively the conclusion of [gl], the hypotheses of [gl], the
+      environment of [gl] (i.e. the global environment and the
+      hypotheses) and the current evar map. *)
+  val concl : ([ `NF ], 'r) t -> Term.constr
+  val hyps : ([ `NF ], 'r) t -> Context.Named.t
+  val env : ('a, 'r) t -> Environ.env
+  val sigma : ('a, 'r) t -> 'r Sigma.t
+  val extra : ('a, 'r) t -> Evd.Store.t
+
+  (** Returns the goal's conclusion even if the goal is not
+      normalised. *)
+  val raw_concl : ('a, 'r) t -> Term.constr
+
+  type ('a, 'b) enter =
+    { enter : 'r. ('a, 'r) t -> 'b }
+
+  (** [nf_enter t] applies the goal-dependent tactic [t] in each goal
+      independently, in the manner of {!tclINDEPENDENT} except that
+      the current goal is also given as an argument to [t]. The goal
+      is normalised with respect to evars. *)
+  val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic
+
+  (** Like {!nf_enter}, but does not normalize the goal beforehand. *)
+  val enter : ([ `LZ ], unit tactic) enter -> unit tactic
+
+  type ('a, 'b) s_enter =
+    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
+
+  (** A variant of {!enter} allows to work with a monotonic state. The evarmap
+      returned by the argument is put back into the current state before firing
+      the returned tactic. *)
+  val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic
+
+  (** Like {!s_enter}, but normalizes the goal beforehand. *)
+  val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic
+
+  (** Recover the list of current goals under focus, without evar-normalization.
+      FIXME: encapsulate the level in an existential type. *)
+  val goals : ([ `LZ ], 'r) t tactic list tactic
+
+  (** Compatibility: avoid if possible *)
+  val goal : ([ `NF ], 'r) t -> Evar.t
+
+  (** Every goal is valid at a later stage. FIXME: take a later evarmap *)
+  val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t
+
+end
+
+
+(** {6 Trace} *)
+
+module Trace : sig
+
+  (** [record_info_trace t] behaves like [t] except the [info] trace
+      is stored. *)
+  val record_info_trace : 'a tactic -> 'a tactic
+
+  val log : Proofview_monad.lazy_msg -> unit tactic
+  val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic
+
+  val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds
+
+end
+
+
+(** {6 Non-logical state} *)
+
+(** The [NonLogical] module allows the execution of effects (including
+    I/O) in tactics (non-logical side-effects are not discarded at
+    failures). *)
+module NonLogical : module type of Logic_monad.NonLogical
+
+(** [tclLIFT c] is a tactic which behaves exactly as [c]. *)
+val tclLIFT : 'a NonLogical.t -> 'a tactic
+
+
+(**/**)
+
+(*** Compatibility layer with <= 8.2 tactics ***)
+module V82 : sig
+  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
+  val tactic : tac -> unit tactic
+
+  (* normalises the evars in the goals, and stores the result in
+     solution. *)
+  val nf_evar_goals : unit tactic
+
+  val has_unresolved_evar : proofview -> bool
+
+  (* Main function in the implementation of Grab Existential Variables.
+     Resets the proofview's goals so that it contains all unresolved evars
+     (in chronological order of insertion). *)
+  val grab : proofview -> proofview
+
+  (* Returns the open goals of the proofview together with the evar_map to 
+     interpret them. *)
+  val goals : proofview -> Evar.t list Evd.sigma
+
+  val top_goals : entry -> proofview -> Evar.t list Evd.sigma
+  
+  (* returns the existential variable used to start the proof *)
+  val top_evars : entry -> Evd.evar list
+
+  (* Caution: this function loses quite a bit of information. It
+     should be avoided as much as possible.  It should work as
+     expected for a tactic obtained from {!V82.tactic} though. *)
+  val of_tactic : 'a tactic -> tac
+
+  (* marks as unsafe if the argument is [false] *)
+  val put_status : bool -> unit tactic
+
+  (* exception for which it is deemed to be safe to transmute into
+     tactic failure. *)
+  val catchable_exception : exn -> bool
+
+  (* transforms every Ocaml (catchable) exception into a failure in
+     the monad. *)
+  val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
+end
+
+(** {7 Notations} *)
+
+module Notations : sig
+
+  (** {!tclBIND} *)
+  val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+  (** {!tclTHEN} *)
+  val (<*>) : unit tactic -> 'a tactic -> 'a tactic
+  (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
+  val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+
+  type ('a, 'b) enter = ('a, 'b) Goal.enter =
+    { enter : 'r. ('a, 'r) Goal.t -> 'b }
+  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
+end
-- 
cgit v1.2.3


From 08c31f46aa05098e1a97d9144599c1e5072b7fc3 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 19:52:54 +0100
Subject: Pushing Proofview further down the dependency alley.

---
 pretyping/pretyping.mllib |  2 +-
 pretyping/proofview.ml    | 11 +++++++++--
 pretyping/proofview.mli   |  3 +++
 pretyping/typeclasses.ml  |  2 +-
 4 files changed, 14 insertions(+), 4 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index 5dfdd0379a..b0d5a1df6a 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -20,8 +20,8 @@ Patternops
 Constr_matching
 Tacred
 Typeclasses_errors
-Typeclasses
 Proofview
+Typeclasses
 Classops
 Program
 Coercion
diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml
index 20be02e76d..ba664cafaf 100644
--- a/pretyping/proofview.ml
+++ b/pretyping/proofview.ml
@@ -56,10 +56,12 @@ type telescope =
   | TNil of Evd.evar_map
   | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
 
+let typeclass_resolvable = Evd.Store.field ()
+
 let dependent_init =
   (* Goals are created with a store which marks them as unresolvable
      for type classes. *)
-  let store = Typeclasses.set_resolvable Evd.Store.empty false in
+  let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in
   (* Goals don't have a source location. *)
   let src = (Loc.ghost,Evar_kinds.GoalEvar) in
   (* Main routine *)
@@ -908,11 +910,16 @@ module Unsafe = struct
       | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
       | loc,_ -> loc,Evar_kinds.GoalEvar }
     in
-    let info = Typeclasses.mark_unresolvable info in
+    let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with
+    | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () }
+    | Some () -> info
+    in
     Evd.add evd content info
 
   let advance = advance
 
+  let typeclass_resolvable = typeclass_resolvable
+
 end
 
 module UnsafeRepr = Proof.Unsafe
diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli
index 6bc2e9a0ed..7996b7969c 100644
--- a/pretyping/proofview.mli
+++ b/pretyping/proofview.mli
@@ -413,6 +413,9 @@ module Unsafe : sig
       into [g']). It returns [None] if [g] has been (partially)
       solved. *)
   val advance : Evd.evar_map -> Evar.t -> Evar.t option
+
+  val typeclass_resolvable : unit Evd.Store.field
+
 end
 
 (** This module gives access to the innards of the monad. Its use is
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 0faa35c875..3a5796fe1b 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -490,7 +490,7 @@ let is_instance = function
    Nota: we will only check the resolvability status of undefined evars.
  *)
 
-let resolvable = Store.field ()
+let resolvable = Proofview.Unsafe.typeclass_resolvable
 
 let set_resolvable s b =
   if b then Store.remove s resolvable
-- 
cgit v1.2.3


From e98d7276f52c4b67bf05a80a6b44f334966f82fd Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 20:11:50 +0100
Subject: Splitting Evarutil in two distinct files.

Some parts of Evarutils were related to the management of evars under constraints.
We put them in the Evardefine file.
---
 pretyping/cases.ml        |   1 +
 pretyping/coercion.ml     |   6 +-
 pretyping/evarconv.ml     |   1 +
 pretyping/evardefine.ml   | 209 ++++++++++++++++++++++++++++++++++++++++++++++
 pretyping/evardefine.mli  |  46 ++++++++++
 pretyping/evarutil.ml     | 191 ++----------------------------------------
 pretyping/evarutil.mli    |  39 ++-------
 pretyping/pretyping.ml    |   1 +
 pretyping/pretyping.mllib |   1 +
 pretyping/typing.ml       |   4 +-
 pretyping/unification.ml  |   1 +
 11 files changed, 275 insertions(+), 225 deletions(-)
 create mode 100644 pretyping/evardefine.ml
 create mode 100644 pretyping/evardefine.mli

(limited to 'pretyping')

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 8a55a7aaa5..c3968f8963 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -25,6 +25,7 @@ open Glob_ops
 open Retyping
 open Pretype_errors
 open Evarutil
+open Evardefine
 open Evarsolve
 open Evarconv
 open Evd
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 57b273d0d5..9d0f391e43 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -245,7 +245,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		       | Lambda (n, t, t') -> c, t'
 			   (*| Prod (n, t, t') -> t'*)
 		       | Evar (k, args) ->
-			   let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in
+			   let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in
 			     evdref := evs;
 			     let (n, dom, rng) = destLambda t in
 			     let dom = whd_evar !evdref dom in
@@ -375,7 +375,7 @@ let inh_app_fun_core env evd j =
     match kind_of_term t with
     | Prod (_,_,_) -> (evd,j)
     | Evar ev ->
-	let (evd',t) = define_evar_as_product evd ev in
+	let (evd',t) = Evardefine.define_evar_as_product evd ev in
 	  (evd',{ uj_val = j.uj_val; uj_type = t })
     | _ ->
       	try let t,p =
@@ -416,7 +416,7 @@ let inh_coerce_to_sort loc env evd j =
     match kind_of_term typ with
     | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
     | Evar ev when not (is_defined evd (fst ev)) ->
-	let (evd',s) = define_evar_as_sort env evd ev in
+	let (evd',s) = Evardefine.define_evar_as_sort env evd ev in
 	  (evd',{ utj_val = j.uj_val; utj_type = s })
     | _ ->
 	inh_tosort_force loc env evd j
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 489a8a729d..08973a05c4 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -18,6 +18,7 @@ open Termops
 open Environ
 open Recordops
 open Evarutil
+open Evardefine
 open Evarsolve
 open Globnames
 open Evd
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
new file mode 100644
index 0000000000..ef3a3f5255
--- /dev/null
+++ b/pretyping/evardefine.ml
@@ -0,0 +1,209 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Errors
+open Util
+open Pp
+open Names
+open Term
+open Vars
+open Termops
+open Namegen
+open Pre_env
+open Environ
+open Evd
+open Evarutil
+open Pretype_errors
+open Sigma.Notations
+
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+  (Sigma.to_evar_map evd, evk)
+
+let env_nf_evar sigma env =
+  let open Context.Rel.Declaration in
+  process_rel_context
+    (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+  let open Context.Rel.Declaration in
+  process_rel_context
+    (fun d e ->
+      push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
+
+(****************************************)
+(* Operations on value/type constraints *)
+(****************************************)
+
+type type_constraint = types option
+
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ *   (false,(None,None)) -> no constraint at all
+ *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
+ *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
+ *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+let mk_valcon c = Some c
+
+let idx = Namegen.default_dependent_ident
+
+(* Refining an evar to a product *)
+
+let define_pure_evar_as_product evd evk =
+  let open Context.Named.Declaration in
+  let evi = Evd.find_undefined evd evk in
+  let evenv = evar_env evi in
+  let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
+  let concl = Reductionops.whd_betadeltaiota evenv evd evi.evar_concl in
+  let s = destSort concl in
+  let evd1,(dom,u1) =
+    let evd = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+    (Sigma.to_evar_map evd1, e)
+  in
+  let evd2,rng =
+    let newenv = push_named (LocalAssum (id, dom)) evenv in
+    let src = evar_source evk evd1 in
+    let filter = Filter.extend 1 (evar_filter evi) in
+      if is_prop_sort s then
+       (* Impredicative product, conclusion must fall in [Prop]. *)
+        new_evar_unsafe newenv evd1 concl ~src ~filter
+      else
+	let status = univ_flexible_alg in
+	let evd3, (rng, srng) =
+          let evd1 = Sigma.Unsafe.of_evar_map evd1 in
+          let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
+          (Sigma.to_evar_map evd3, e)
+        in
+	let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
+	let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
+	  evd3, rng
+  in
+  let prod = mkProd (Name id, dom, subst_var id rng) in
+  let evd3 = Evd.define evk prod evd2 in
+    evd3,prod
+
+(* Refine an applied evar to a product and returns its instantiation *)
+
+let define_evar_as_product evd (evk,args) =
+  let evd,prod = define_pure_evar_as_product evd evk in
+  (* Quick way to compute the instantiation of evk with args *)
+  let na,dom,rng = destProd prod in
+  let evdom = mkEvar (fst (destEvar dom), args) in
+  let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+  let evrng =  mkEvar (fst (destEvar rng), evrngargs) in
+  evd,mkProd (na, evdom, evrng)
+
+(* Refine an evar with an abstraction
+
+   I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
+   - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
+     or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
+        with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
+   - x1..xq,y:A |- ?e':B
+*)
+
+let define_pure_evar_as_lambda env evd evk =
+  let open Context.Named.Declaration in
+  let evi = Evd.find_undefined evd evk in
+  let evenv = evar_env evi in
+  let typ = Reductionops.whd_betadeltaiota evenv evd (evar_concl evi) in
+  let evd1,(na,dom,rng) = match kind_of_term typ with
+  | Prod (na,dom,rng) -> (evd,(na,dom,rng))
+  | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
+  | _ -> error_not_product_loc Loc.ghost env evd typ in
+  let avoid = ids_of_named_context (evar_context evi) in
+  let id =
+    next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in
+  let newenv = push_named (LocalAssum (id, dom)) evenv in
+  let filter = Filter.extend 1 (evar_filter evi) in
+  let src = evar_source evk evd1 in
+  let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+  let lam = mkLambda (Name id, dom, subst_var id body) in
+  Evd.define evk lam evd2, lam
+
+let define_evar_as_lambda env evd (evk,args) =
+  let evd,lam = define_pure_evar_as_lambda env evd evk in
+  (* Quick way to compute the instantiation of evk with args *)
+  let na,dom,body = destLambda lam in
+  let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+  let evbody = mkEvar (fst (destEvar body), evbodyargs) in
+  evd,mkLambda (na, dom, evbody)
+
+let rec evar_absorb_arguments env evd (evk,args as ev) = function
+  | [] -> evd,ev
+  | a::l ->
+      (* TODO: optimize and avoid introducing intermediate evars *)
+      let evd,lam = define_pure_evar_as_lambda env evd evk in
+      let _,_,body = destLambda lam in
+      let evk = fst (destEvar body) in
+      evar_absorb_arguments env evd (evk, Array.cons a args) l
+
+(* Refining an evar to a sort *)
+
+let define_evar_as_sort env evd (ev,args) =
+  let evd, u = new_univ_variable univ_rigid evd in
+  let evi = Evd.find_undefined evd ev in 
+  let s = Type u in
+  let concl = Reductionops.whd_betadeltaiota (evar_env evi) evd evi.evar_concl in
+  let sort = destSort concl in
+  let evd' = Evd.define ev (mkSort s) evd in
+  Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
+
+(* Propagation of constraints through application and abstraction:
+   Given a type constraint on a functional term, returns the type
+   constraint on its domain and codomain. If the input constraint is
+   an evar instantiate it with the product of 2 new evars. *)
+
+let split_tycon loc env evd tycon =
+  let rec real_split evd c =
+    let t = Reductionops.whd_betadeltaiota env evd c in
+      match kind_of_term t with
+	| Prod (na,dom,rng) -> evd, (na, dom, rng)
+	| Evar ev (* ev is undefined because of whd_betadeltaiota *) ->
+	    let (evd',prod) = define_evar_as_product evd ev in
+	    let (_,dom,rng) = destProd prod in
+	      evd',(Anonymous, dom, rng)
+	| App (c,args) when isEvar c ->
+	    let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
+	    real_split evd' (mkApp (lam,args))
+	| _ -> error_not_product_loc loc env evd c
+  in
+    match tycon with
+      | None -> evd,(Anonymous,None,None)
+      | Some c ->
+	  let evd', (n, dom, rng) = real_split evd c in
+	    evd', (n, mk_tycon dom, mk_tycon rng)
+
+let valcon_of_tycon x = x
+let lift_tycon n = Option.map (lift n)
+
+let pr_tycon env = function
+    None -> str "None"
+  | Some t -> Termops.print_constr_env env t
diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli
new file mode 100644
index 0000000000..07b0e69d9f
--- /dev/null
+++ b/pretyping/evardefine.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Term
+open Evd
+open Environ
+
+val env_nf_evar : evar_map -> env -> env
+val env_nf_betaiotaevar : evar_map -> env -> env
+
+type type_constraint = types option
+type val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : constr -> type_constraint
+val empty_valcon : val_constraint
+val mk_valcon : constr -> val_constraint
+
+(** Instantiate an evar by as many lambda's as needed so that its arguments
+    are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
+    [?y[vars1:=args1,vars:=args]] with
+    [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
+val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
+  evar_map * existential
+
+val split_tycon :
+  Loc.t -> env ->  evar_map -> type_constraint ->
+    evar_map * (Name.t * type_constraint * type_constraint)
+
+val valcon_of_tycon : type_constraint -> val_constraint
+val lift_tycon : int -> type_constraint -> type_constraint
+
+val define_evar_as_product : evar_map -> existential -> evar_map * types
+val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
+val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
+
+(** {6 debug pretty-printer:} *)
+
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
+
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index ab70de0578..35b66918cb 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -17,7 +17,6 @@ open Namegen
 open Pre_env
 open Environ
 open Evd
-open Reductionops
 open Pretype_errors
 open Sigma.Notations
 
@@ -76,17 +75,6 @@ let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
 let tj_nf_evar sigma {utj_val=v;utj_type=t} =
   {utj_val=nf_evar sigma v;utj_type=t}
 
-let env_nf_evar sigma env =
-  let open Context.Rel.Declaration in
-  process_rel_context
-    (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env
-
-let env_nf_betaiotaevar sigma env =
-  let open Context.Rel.Declaration in
-  process_rel_context
-    (fun d e ->
-      push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
-
 let nf_evars_universes evm =
   Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) 
     (Evd.universe_subst evm)
@@ -481,7 +469,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
       | Evar (evk,l as ev) ->
 	  if Evd.is_defined !evdref evk then
 	    (* If evk is already defined we replace it by its definition *)
-	    let nc = whd_evar !evdref c in
+	    let nc = Reductionops.whd_evar !evdref c in
 	      (check_and_clear_in_constr env evdref err ids nc)
 	  else
 	    (* We check for dependencies to elements of ids in the
@@ -536,7 +524,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
 	      let evi' = { evi with evar_extra = extra' } in
 	      evdref := Evd.add !evdref evk evi' ;
 	    (* spiwack: /hacking session *)
-              whd_evar !evdref c
+              Reductionops.whd_evar !evdref c
 
       | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
 
@@ -688,146 +676,6 @@ let occur_evar_upto sigma n c =
   in
   try occur_rec c; false with Occur -> true
 
-
-(****************************************)
-(* Operations on value/type constraints *)
-(****************************************)
-
-type type_constraint = types option
-
-type val_constraint = constr option
-
-(* Old comment...
- * Basically, we have the following kind of constraints (in increasing
- * strength order):
- *   (false,(None,None)) -> no constraint at all
- *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
- *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
- *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
- * Maybe a concrete datatype would be easier to understand.
- * We differentiate (true,(None,None)) from (_,(None,Some Type))
- * because otherwise Case(s) would be misled, as in
- * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
- * of Set.
- *)
-
-(* The empty type constraint *)
-let empty_tycon = None
-
-(* Builds a type constraint *)
-let mk_tycon ty = Some ty
-
-(* Constrains the value of a type *)
-let empty_valcon = None
-
-(* Builds a value constraint *)
-let mk_valcon c = Some c
-
-let idx = Namegen.default_dependent_ident
-
-(* Refining an evar to a product *)
-
-let define_pure_evar_as_product evd evk =
-  let open Context.Named.Declaration in
-  let evi = Evd.find_undefined evd evk in
-  let evenv = evar_env evi in
-  let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
-  let concl = whd_betadeltaiota evenv evd evi.evar_concl in
-  let s = destSort concl in
-  let evd1,(dom,u1) =
-    let evd = Sigma.Unsafe.of_evar_map evd in
-    let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
-    (Sigma.to_evar_map evd1, e)
-  in
-  let evd2,rng =
-    let newenv = push_named (LocalAssum (id, dom)) evenv in
-    let src = evar_source evk evd1 in
-    let filter = Filter.extend 1 (evar_filter evi) in
-      if is_prop_sort s then
-       (* Impredicative product, conclusion must fall in [Prop]. *)
-        new_evar_unsafe newenv evd1 concl ~src ~filter
-      else
-	let status = univ_flexible_alg in
-	let evd3, (rng, srng) =
-          let evd1 = Sigma.Unsafe.of_evar_map evd1 in
-          let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
-          (Sigma.to_evar_map evd3, e)
-        in
-	let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
-	let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
-	  evd3, rng
-  in
-  let prod = mkProd (Name id, dom, subst_var id rng) in
-  let evd3 = Evd.define evk prod evd2 in
-    evd3,prod
-
-(* Refine an applied evar to a product and returns its instantiation *)
-
-let define_evar_as_product evd (evk,args) =
-  let evd,prod = define_pure_evar_as_product evd evk in
-  (* Quick way to compute the instantiation of evk with args *)
-  let na,dom,rng = destProd prod in
-  let evdom = mkEvar (fst (destEvar dom), args) in
-  let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
-  let evrng =  mkEvar (fst (destEvar rng), evrngargs) in
-  evd,mkProd (na, evdom, evrng)
-
-(* Refine an evar with an abstraction
-
-   I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
-   - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
-     or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
-        with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
-   - x1..xq,y:A |- ?e':B
-*)
-
-let define_pure_evar_as_lambda env evd evk =
-  let open Context.Named.Declaration in
-  let evi = Evd.find_undefined evd evk in
-  let evenv = evar_env evi in
-  let typ = whd_betadeltaiota evenv evd (evar_concl evi) in
-  let evd1,(na,dom,rng) = match kind_of_term typ with
-  | Prod (na,dom,rng) -> (evd,(na,dom,rng))
-  | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
-  | _ -> error_not_product_loc Loc.ghost env evd typ in
-  let avoid = ids_of_named_context (evar_context evi) in
-  let id =
-    next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
-  let newenv = push_named (LocalAssum (id, dom)) evenv in
-  let filter = Filter.extend 1 (evar_filter evi) in
-  let src = evar_source evk evd1 in
-  let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
-  let lam = mkLambda (Name id, dom, subst_var id body) in
-  Evd.define evk lam evd2, lam
-
-let define_evar_as_lambda env evd (evk,args) =
-  let evd,lam = define_pure_evar_as_lambda env evd evk in
-  (* Quick way to compute the instantiation of evk with args *)
-  let na,dom,body = destLambda lam in
-  let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
-  let evbody = mkEvar (fst (destEvar body), evbodyargs) in
-  evd,mkLambda (na, dom, evbody)
-
-let rec evar_absorb_arguments env evd (evk,args as ev) = function
-  | [] -> evd,ev
-  | a::l ->
-      (* TODO: optimize and avoid introducing intermediate evars *)
-      let evd,lam = define_pure_evar_as_lambda env evd evk in
-      let _,_,body = destLambda lam in
-      let evk = fst (destEvar body) in
-      evar_absorb_arguments env evd (evk, Array.cons a args) l
-
-(* Refining an evar to a sort *)
-
-let define_evar_as_sort env evd (ev,args) =
-  let evd, u = new_univ_variable univ_rigid evd in
-  let evi = Evd.find_undefined evd ev in 
-  let s = Type u in
-  let concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in
-  let sort = destSort concl in
-  let evd' = Evd.define ev (mkSort s) evd in
-  Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
-
 (* We don't try to guess in which sort the type should be defined, since
    any type has type Type. May cause some trouble, but not so far... *)
 
@@ -835,38 +683,6 @@ let judge_of_new_Type evd =
   let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in
   Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p)
 
-(* Propagation of constraints through application and abstraction:
-   Given a type constraint on a functional term, returns the type
-   constraint on its domain and codomain. If the input constraint is
-   an evar instantiate it with the product of 2 new evars. *)
-
-let split_tycon loc env evd tycon =
-  let rec real_split evd c =
-    let t = whd_betadeltaiota env evd c in
-      match kind_of_term t with
-	| Prod (na,dom,rng) -> evd, (na, dom, rng)
-	| Evar ev (* ev is undefined because of whd_betadeltaiota *) ->
-	    let (evd',prod) = define_evar_as_product evd ev in
-	    let (_,dom,rng) = destProd prod in
-	      evd',(Anonymous, dom, rng)
-	| App (c,args) when isEvar c ->
-	    let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
-	    real_split evd' (mkApp (lam,args))
-	| _ -> error_not_product_loc loc env evd c
-  in
-    match tycon with
-      | None -> evd,(Anonymous,None,None)
-      | Some c ->
-	  let evd', (n, dom, rng) = real_split evd c in
-	    evd', (n, mk_tycon dom, mk_tycon rng)
-
-let valcon_of_tycon x = x
-let lift_tycon n = Option.map (lift n)
-
-let pr_tycon env = function
-    None -> str "None"
-  | Some t -> Termops.print_constr_env env t
-
 let subterm_source evk (loc,k) =
   let evk = match k with
     | Evar_kinds.SubEvar (evk) -> evk
@@ -897,3 +713,6 @@ let eq_constr_univs_test sigma1 sigma2 t u =
       (universes sigma2) fold t u sigma2
   in
   match ans with None -> false | Some _ -> true
+
+type type_constraint = types option
+type val_constraint = constr option
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index bc4c37a918..a4f8527652 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -100,17 +100,6 @@ val is_ground_env  :  evar_map -> env -> bool
    new unresolved evar remains in [c] *)
 val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
-val define_evar_as_product : evar_map -> existential -> evar_map * types
-val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
-val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
-
-(** Instantiate an evar by as many lambda's as needed so that its arguments
-    are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
-    [?y[vars1:=args1,vars:=args]] with
-    [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
-val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
-  evar_map * existential
-
 (** [gather_dependent_evars evm seeds] classifies the evars in [evm]
     as dependent_evars and goals (these may overlap). A goal is an
     evar in [seeds] or an evar appearing in the (partial) definition
@@ -140,21 +129,6 @@ val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
 
 val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma
 
-type type_constraint = types option
-type val_constraint = constr option
-
-val empty_tycon : type_constraint
-val mk_tycon : constr -> type_constraint
-val empty_valcon : val_constraint
-val mk_valcon : constr -> val_constraint
-
-val split_tycon :
-  Loc.t -> env ->  evar_map -> type_constraint ->
-    evar_map * (Name.t * type_constraint * type_constraint)
-
-val valcon_of_tycon : type_constraint -> val_constraint
-val lift_tycon : int -> type_constraint -> type_constraint
-
 (***********************************************************)
 
 (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
@@ -177,9 +151,6 @@ val nf_evar_info : evar_map -> evar_info -> evar_info
 val nf_evar_map : evar_map -> evar_map
 val nf_evar_map_undefined : evar_map -> evar_map
 
-val env_nf_evar : evar_map -> env -> env
-val env_nf_betaiotaevar : evar_map -> env -> env
-
 val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment
 val jv_nf_betaiotaevar :
   evar_map -> unsafe_judgment array -> unsafe_judgment array
@@ -212,11 +183,6 @@ val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term
     assumed to be an extention of those in [sigma1]. *)
 val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool
 
-(** {6 debug pretty-printer:} *)
-
-val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
-
-
 (** {6 Removing hyps in evars'context}
 raise OccurHypInSimpleClause if the removal breaks dependencies *)
 
@@ -251,3 +217,8 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
   Evar_kinds.t Loc.located
 
 val meta_counter_summary_name : string
+
+(** Deprecater *)
+
+type type_constraint = types option
+type val_constraint = constr option
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 8329de2ee4..30e26c6f89 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -36,6 +36,7 @@ open Typeops
 open Globnames
 open Nameops
 open Evarutil
+open Evardefine
 open Pretype_errors
 open Glob_term
 open Glob_ops
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index b0d5a1df6a..e8c0bbbf90 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -9,6 +9,7 @@ Cbv
 Pretype_errors
 Find_subterm
 Evarutil
+Evardefine
 Evarsolve
 Recordops
 Evarconv
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 5347d965b5..52afa7f83a 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -39,7 +39,7 @@ let e_type_judgment env evdref j =
   match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with
     | Sort s -> {utj_val = j.uj_val; utj_type = s }
     | Evar ev ->
-        let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in
+        let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in
         evdref := evd; { utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -61,7 +61,7 @@ let e_judge_of_apply env evdref funj argjv =
 	 else
 	   error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv
       | Evar ev ->
-	  let (evd',t) = Evarutil.define_evar_as_product !evdref ev in
+	  let (evd',t) = Evardefine.define_evar_as_product !evdref ev in
           evdref := evd';
           let (_,_,c2) = destProd t in
 	  apply_rec (n+1) (subst1 hj.uj_val c2) restjl
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index a7b415552a..a4a386530d 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -19,6 +19,7 @@ open Evd
 open Reduction
 open Reductionops
 open Evarutil
+open Evardefine
 open Evarsolve
 open Pretype_errors
 open Retyping
-- 
cgit v1.2.3


From c3de822e711fa3f10817432b7023fc2f88c0aeeb Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 20:41:17 +0100
Subject: Making Evarutil independent from Reductionops.

---
 pretyping/evarutil.ml     | 61 +++++++++++++++++++++++++----------------------
 pretyping/evarutil.mli    |  9 +++----
 pretyping/pretyping.ml    | 17 +++++++++++++
 pretyping/pretyping.mli   |  4 ++++
 pretyping/pretyping.mllib |  4 ++--
 pretyping/reductionops.ml | 30 +++--------------------
 6 files changed, 62 insertions(+), 63 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 35b66918cb..2bd67dcdc8 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -17,9 +17,12 @@ open Namegen
 open Pre_env
 open Environ
 open Evd
-open Pretype_errors
 open Sigma.Notations
 
+let safe_evar_value sigma ev =
+  try Some (Evd.existential_value sigma ev)
+  with NotInstantiatedEvar | Not_found -> None
+
 (** Combinators *)
 
 let evd_comb0 f evdref =
@@ -61,22 +64,41 @@ let rec flush_and_check_evars sigma c =
 
 (* let nf_evar_key = Profile.declare_profile "nf_evar"  *)
 (* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *)
-let nf_evar = Reductionops.nf_evar
+
+let rec whd_evar sigma c =
+  match kind_of_term c with
+    | Evar ev ->
+        let (evk, args) = ev in
+        let args = Array.map (fun c -> whd_evar sigma c) args in
+        (match safe_evar_value sigma (evk, args) with
+            Some c -> whd_evar sigma c
+          | None -> c)
+    | Sort (Type u) -> 
+      let u' = Evd.normalize_universe sigma u in
+	if u' == u then c else mkSort (Sorts.sort_of_univ u')
+    | Const (c', u) when not (Univ.Instance.is_empty u) -> 
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkConstU (c', u')
+    | Ind (i, u) when not (Univ.Instance.is_empty u) -> 
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkIndU (i, u')
+    | Construct (co, u) when not (Univ.Instance.is_empty u) ->
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkConstructU (co, u')
+    | _ -> c
+
+let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t)
+
 let j_nf_evar sigma j =
   { uj_val = nf_evar sigma j.uj_val;
     uj_type = nf_evar sigma j.uj_type }
-let j_nf_betaiotaevar sigma j =
-  { uj_val = nf_evar sigma j.uj_val;
-    uj_type = Reductionops.nf_betaiota sigma j.uj_type }
 let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
-let jv_nf_betaiotaevar sigma jl =
-  Array.map (j_nf_betaiotaevar sigma) jl
 let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
 let tj_nf_evar sigma {utj_val=v;utj_type=t} =
   {utj_val=nf_evar sigma v;utj_type=t}
 
 let nf_evars_universes evm =
-  Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) 
+  Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) 
     (Evd.universe_subst evm)
     
 let nf_evars_and_universes evm =
@@ -469,7 +491,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
       | Evar (evk,l as ev) ->
 	  if Evd.is_defined !evdref evk then
 	    (* If evk is already defined we replace it by its definition *)
-	    let nc = Reductionops.whd_evar !evdref c in
+	    let nc = whd_evar !evdref c in
 	      (check_and_clear_in_constr env evdref err ids nc)
 	  else
 	    (* We check for dependencies to elements of ids in the
@@ -524,7 +546,7 @@ let rec check_and_clear_in_constr env evdref err ids c =
 	      let evi' = { evi with evar_extra = extra' } in
 	      evdref := Evd.add !evdref evk evi' ;
 	    (* spiwack: /hacking session *)
-              Reductionops.whd_evar !evdref c
+              whd_evar !evdref c
 
       | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
 
@@ -647,23 +669,6 @@ let undefined_evars_of_evar_info evd evi =
        (undefined_evars_of_named_context evd
 	  (named_context_of_val evi.evar_hyps)))
 
-(* [check_evars] fails if some unresolved evar remains *)
-
-let check_evars env initial_sigma sigma c =
-  let rec proc_rec c =
-    match kind_of_term c with
-    | Evar (evk,_ as ev) ->
-        (match existential_opt_value sigma ev with
-        | Some c -> proc_rec c
-        | None ->
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk sigma in
-	      match k with
-	      | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
-	      | _ -> error_unsolvable_implicit loc env sigma evk None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
 (* spiwack: this is a more complete version of
    {!Termops.occur_evar}. The latter does not look recursively into an
    [evar_map]. If unification only need to check superficially, tactics
@@ -692,7 +697,7 @@ let subterm_source evk (loc,k) =
 
 (** Term exploration up to instantiation. *)
 let kind_of_term_upto sigma t =
-  Constr.kind (Reductionops.whd_evar sigma t)
+  Constr.kind (whd_evar sigma t)
 
 (** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
     [u] up to existential variable instantiation and equalisable
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index a4f8527652..ffff2c5dd9 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -78,6 +78,8 @@ val new_evar_instance :
 
 val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
 
+val safe_evar_value : evar_map -> existential -> constr option
+
 (** {6 Evars/Metas switching...} *)
 
 val non_instantiated : evar_map -> evar_info Evar.Map.t
@@ -96,9 +98,6 @@ val has_undefined_evars : evar_map -> constr -> bool
 
 val is_ground_term :  evar_map -> constr -> bool
 val is_ground_env  :  evar_map -> env -> bool
-(** [check_evars env initial_sigma extended_sigma c] fails if some
-   new unresolved evar remains in [c] *)
-val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
 (** [gather_dependent_evars evm seeds] classifies the evars in [evm]
     as dependent_evars and goals (these may overlap). A goal is an
@@ -134,6 +133,7 @@ val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma
 (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
     uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
 
+val whd_evar :  evar_map -> constr -> constr
 val nf_evar :  evar_map -> constr -> constr
 val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
 val jl_nf_evar :
@@ -151,9 +151,6 @@ val nf_evar_info : evar_map -> evar_info -> evar_info
 val nf_evar_map : evar_map -> evar_map
 val nf_evar_map_undefined : evar_map -> evar_map
 
-val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jv_nf_betaiotaevar :
-  evar_map -> unsafe_judgment array -> unsafe_judgment array
 (** Presenting terms without solved evars *)
 
 val nf_evars_universes : evar_map -> constr -> constr
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 30e26c6f89..a765d30913 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -235,6 +235,23 @@ let check_extra_evars_are_solved env current_sigma pending =
 	| _ ->
 	    error_unsolvable_implicit loc env current_sigma evk None) pending
 
+(* [check_evars] fails if some unresolved evar remains *)
+
+let check_evars env initial_sigma sigma c =
+  let rec proc_rec c =
+    match kind_of_term c with
+    | Evar (evk,_ as ev) ->
+        (match existential_opt_value sigma ev with
+        | Some c -> proc_rec c
+        | None ->
+	  if not (Evd.mem initial_sigma evk) then
+            let (loc,k) = evar_source evk sigma in
+	      match k with
+	      | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+	      | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None)
+      | _ -> Constr.iter proc_rec c
+  in proc_rec c
+
 let check_evars_are_solved env current_sigma frozen pending =
   check_typeclasses_instances_are_solved env current_sigma frozen;
   check_problems_are_solved env current_sigma;
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 40745ed097..4c4c535d8c 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -130,6 +130,10 @@ val solve_remaining_evars : inference_flags ->
 val check_evars_are_solved :
   env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
 
+(** [check_evars env initial_sigma extended_sigma c] fails if some
+   new unresolved evar remains in [c] *)
+val check_evars : env -> evar_map -> evar_map -> constr -> unit
+
 (**/**)
 (** Internal of Pretyping... *)
 val pretype :
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index e8c0bbbf90..be517d1aa0 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,4 +1,6 @@
 Locusops
+Pretype_errors
+Evarutil
 Reductionops
 Inductiveops
 Vnorm
@@ -6,9 +8,7 @@ Arguments_renaming
 Nativenorm
 Retyping
 Cbv
-Pretype_errors
 Find_subterm
-Evarutil
 Evardefine
 Evarsolve
 Recordops
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 935e18d8dd..7f4249c5b6 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -594,9 +594,7 @@ let pr_state (tm,sk) =
 (*** Reduction Functions Operators ***)
 (*************************************)
 
-let safe_evar_value sigma ev =
-  try Some (Evd.existential_value sigma ev)
-  with NotInstantiatedEvar | Not_found -> None
+let safe_evar_value = Evarutil.safe_evar_value
 
 let safe_meta_value sigma ev =
   try Some (Evd.meta_value sigma ev)
@@ -1183,30 +1181,8 @@ let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty))
 (****************************************************************************)
 
 (* Replacing defined evars for error messages *)
-let rec whd_evar sigma c =
-  match kind_of_term c with
-    | Evar ev ->
-        let (evk, args) = ev in
-        let args = Array.map (fun c -> whd_evar sigma c) args in
-        (match safe_evar_value sigma (evk, args) with
-            Some c -> whd_evar sigma c
-          | None -> c)
-    | Sort (Type u) -> 
-      let u' = Evd.normalize_universe sigma u in
-	if u' == u then c else mkSort (Sorts.sort_of_univ u')
-    | Const (c', u) when not (Univ.Instance.is_empty u) -> 
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkConstU (c', u')
-    | Ind (i, u) when not (Univ.Instance.is_empty u) -> 
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkIndU (i, u')
-    | Construct (co, u) when not (Univ.Instance.is_empty u) ->
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkConstructU (co, u')
-    | _ -> c
-
-let nf_evar =
-  local_strong whd_evar
+let whd_evar = Evarutil.whd_evar
+let nf_evar = Evarutil.nf_evar
 
 (* lazy reduction functions. The infos must be created for each term *)
 (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
-- 
cgit v1.2.3


From 528bc26b7a6ee63bb35fc8ada56b021da65f9834 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 21:06:04 +0100
Subject: Moving Evarutil and Proofview to engine/

---
 pretyping/evarutil.ml     |  723 ---------------------------
 pretyping/evarutil.mli    |  221 ---------
 pretyping/pretyping.mllib |    2 -
 pretyping/proofview.ml    | 1211 ---------------------------------------------
 pretyping/proofview.mli   |  589 ----------------------
 5 files changed, 2746 deletions(-)
 delete mode 100644 pretyping/evarutil.ml
 delete mode 100644 pretyping/evarutil.mli
 delete mode 100644 pretyping/proofview.ml
 delete mode 100644 pretyping/proofview.mli

(limited to 'pretyping')

diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
deleted file mode 100644
index 2bd67dcdc8..0000000000
--- a/pretyping/evarutil.ml
+++ /dev/null
@@ -1,723 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Errors
-open Util
-open Pp
-open Names
-open Term
-open Vars
-open Termops
-open Namegen
-open Pre_env
-open Environ
-open Evd
-open Sigma.Notations
-
-let safe_evar_value sigma ev =
-  try Some (Evd.existential_value sigma ev)
-  with NotInstantiatedEvar | Not_found -> None
-
-(** Combinators *)
-
-let evd_comb0 f evdref =
-  let (evd',x) = f !evdref in
-    evdref := evd';
-    x
-
-let evd_comb1 f evdref x =
-  let (evd',y) = f !evdref x in
-    evdref := evd';
-    y
-
-let evd_comb2 f evdref x y =
-  let (evd',z) = f !evdref x y in
-    evdref := evd';
-    z
-
-let e_new_global evdref x = 
-  evd_comb1 (Evd.fresh_global (Global.env())) evdref x
-
-let new_global evd x = 
-  Sigma.fresh_global (Global.env()) evd x
-
-(****************************************************)
-(* Expanding/testing/exposing existential variables *)
-(****************************************************)
-
-(* flush_and_check_evars fails if an existential is undefined *)
-
-exception Uninstantiated_evar of existential_key
-
-let rec flush_and_check_evars sigma c =
-  match kind_of_term c with
-  | Evar (evk,_ as ev) ->
-      (match existential_opt_value sigma ev with
-       | None -> raise (Uninstantiated_evar evk)
-       | Some c -> flush_and_check_evars sigma c)
-  | _ -> map_constr (flush_and_check_evars sigma) c
-
-(* let nf_evar_key = Profile.declare_profile "nf_evar"  *)
-(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *)
-
-let rec whd_evar sigma c =
-  match kind_of_term c with
-    | Evar ev ->
-        let (evk, args) = ev in
-        let args = Array.map (fun c -> whd_evar sigma c) args in
-        (match safe_evar_value sigma (evk, args) with
-            Some c -> whd_evar sigma c
-          | None -> c)
-    | Sort (Type u) -> 
-      let u' = Evd.normalize_universe sigma u in
-	if u' == u then c else mkSort (Sorts.sort_of_univ u')
-    | Const (c', u) when not (Univ.Instance.is_empty u) -> 
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkConstU (c', u')
-    | Ind (i, u) when not (Univ.Instance.is_empty u) -> 
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkIndU (i, u')
-    | Construct (co, u) when not (Univ.Instance.is_empty u) ->
-      let u' = Evd.normalize_universe_instance sigma u in
-	if u' == u then c else mkConstructU (co, u')
-    | _ -> c
-
-let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t)
-
-let j_nf_evar sigma j =
-  { uj_val = nf_evar sigma j.uj_val;
-    uj_type = nf_evar sigma j.uj_type }
-let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
-let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
-let tj_nf_evar sigma {utj_val=v;utj_type=t} =
-  {utj_val=nf_evar sigma v;utj_type=t}
-
-let nf_evars_universes evm =
-  Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) 
-    (Evd.universe_subst evm)
-    
-let nf_evars_and_universes evm =
-  let evm = Evd.nf_constraints evm in
-    evm, nf_evars_universes evm
-
-let e_nf_evars_and_universes evdref =
-  evdref := Evd.nf_constraints !evdref;
-  nf_evars_universes !evdref, Evd.universe_subst !evdref
-
-let nf_evar_map_universes evm =
-  let evm = Evd.nf_constraints evm in
-  let subst = Evd.universe_subst evm in
-    if Univ.LMap.is_empty subst then evm, nf_evar evm
-    else
-      let f = nf_evars_universes evm in
-	Evd.raw_map (fun _ -> map_evar_info f) evm, f
-
-let nf_named_context_evar sigma ctx =
-  Context.Named.map (nf_evar sigma) ctx
-
-let nf_rel_context_evar sigma ctx =
-  Context.Rel.map (nf_evar sigma) ctx
-
-let nf_env_evar sigma env =
-  let nc' = nf_named_context_evar sigma (Environ.named_context env) in
-  let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in
-    push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
-
-let nf_evar_info evc info = map_evar_info (nf_evar evc) info
-
-let nf_evar_map evm =
-  Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm
-
-let nf_evar_map_undefined evm =
-  Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm
-
-(*-------------------*)
-(* Auxiliary functions for the conversion algorithms modulo evars
- *)
-
-(* A probably faster though more approximative variant of
-   [has_undefined (nf_evar c)]: instances are not substituted and
-   maybe an evar occurs in an instance and it would disappear by
-   instantiation *)
-
-let has_undefined_evars evd t =
-  let rec has_ev t =
-    match kind_of_term t with
-    | Evar (ev,args) ->
-        (match evar_body (Evd.find evd ev) with
-        | Evar_defined c ->
-            has_ev c; Array.iter has_ev args
-        | Evar_empty ->
-	    raise NotInstantiatedEvar)
-    | _ -> iter_constr has_ev t in
-  try let _ = has_ev t in false
-  with (Not_found | NotInstantiatedEvar) -> true
-
-let is_ground_term evd t =
-  not (has_undefined_evars evd t)
-
-let is_ground_env evd env =
-  let open Context.Rel.Declaration in
-  let is_ground_rel_decl = function
-    | LocalDef (_,b,_) -> is_ground_term evd b
-    | _ -> true in
-  let open Context.Named.Declaration in
-  let is_ground_named_decl = function
-    | LocalDef (_,b,_) -> is_ground_term evd b
-    | _ -> true in
-  List.for_all is_ground_rel_decl (rel_context env) &&
-  List.for_all is_ground_named_decl (named_context env)
-
-(* Memoization is safe since evar_map and environ are applicative
-   structures *)
-let memo f =
-  let m = ref None in
-  fun x y -> match !m with
-  | Some (x', y', r) when x == x' && y == y' -> r
-  | _ -> let r = f x y in m := Some (x, y, r); r
-
-let is_ground_env = memo is_ground_env
-
-(* Return the head evar if any *)
-
-exception NoHeadEvar
-
-let head_evar =
-  let rec hrec c = match kind_of_term c with
-    | Evar (evk,_)   -> evk
-    | Case (_,_,c,_) -> hrec c
-    | App (c,_)      -> hrec c
-    | Cast (c,_,_)   -> hrec c
-    | _              -> raise NoHeadEvar
-  in
-  hrec
-
-(* Expand head evar if any (currently consider only applications but I
-   guess it should consider Case too) *)
-
-let whd_head_evar_stack sigma c =
-  let rec whrec (c, l as s) =
-    match kind_of_term c with
-      | Evar (evk,args as ev) ->
-        let v =
-          try Some (existential_value sigma ev)
-          with NotInstantiatedEvar | Not_found  -> None in
-        begin match v with
-        | None -> s
-        | Some c -> whrec (c, l)
-        end
-      | Cast (c,_,_) -> whrec (c, l)
-      | App (f,args) -> whrec (f, args :: l)
-      | _ -> s
-  in
-  whrec (c, [])
-
-let whd_head_evar sigma c =
-  let (f, args) = whd_head_evar_stack sigma c in
-  (** optim: don't reallocate if empty/singleton *)
-  match args with
-  | [] -> f
-  | [arg] -> mkApp (f, arg)
-  | _ -> mkApp (f, Array.concat args)
-
-(**********************)
-(* Creating new metas *)
-(**********************)
-
-let meta_counter_summary_name = "meta counter"
-
-(* Generator of metavariables *)
-let new_meta =
-  let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in
-  fun () -> incr meta_ctr; !meta_ctr
-
-let mk_new_meta () = mkMeta(new_meta())
-
-(* The list of non-instantiated existential declarations (order is important) *)
-
-let non_instantiated sigma =
-  let listev = Evd.undefined_map sigma in
-  Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev
-
-(************************)
-(* Manipulating filters *)
-(************************)
-
-let make_pure_subst evi args =
-  let open Context.Named.Declaration in
-  snd (List.fold_right
-    (fun decl (args,l) ->
-      match args with
-        | a::rest -> (rest, (get_id decl, a)::l)
-        | _ -> anomaly (Pp.str "Instance does not match its signature"))
-    (evar_filtered_context evi) (Array.rev_to_list args,[]))
-
-(*------------------------------------*
- * functional operations on evar sets *
- *------------------------------------*)
-
-(* [push_rel_context_to_named_context] builds the defining context and the
- * initial instance of an evar. If the evar is to be used in context
- *
- * Gamma =  a1     ...    an xp      ...       x1
- *          \- named part -/ \- de Bruijn part -/
- *
- * then the x1...xp are turned into variables so that the evar is declared in
- * context
- *
- *          a1     ...    an xp      ...       x1
- *          \----------- named part ------------/
- *
- * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
- * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
- * in context Gamma.
- *
- * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
- * Remark 2: If some of the ai or xj are definitions, we keep them in the
- *   instance. This is necessary so that no unfolding of local definitions
- *   happens when inferring implicit arguments (consider e.g. the problem
- *   "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which
- *   produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
- *   the hole to be instantiated by x', not by x (which would have been
- *   the case in [invert_definition] if x' had disappeared from the instance).
- *   Note that at any time, if, in some context env, the instance of
- *   declaration x:A is t and the instance of definition x':=phi(x) is u, then
- *   we have the property that u and phi(t) are convertible in env.
- *)
-
-let subst2 subst vsubst c =
-  substl subst (replace_vars vsubst c)
-
-let push_rel_context_to_named_context env typ =
-  (* compute the instances relative to the named context and rel_context *)
-  let open Context.Named.Declaration in
-  let ids = List.map get_id (named_context env) in
-  let inst_vars = List.map mkVar ids in
-  let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
-  let replace_var_named_declaration id0 id decl =
-    let id' = get_id decl in
-    let id' = if Id.equal id0 id' then id else id' in
-    let vsubst = [id0 , mkVar id] in
-    decl |> set_id id' |> map_constr (replace_vars vsubst)
-  in
-  let replace_var_named_context id0 id  env =
-    let nc = Environ.named_context env in
-    let nc' = List.map (replace_var_named_declaration id0 id) nc in
-    Environ.reset_with_named_context (val_of_named_context nc') env
-  in
-  let extract_if_neq id = function
-    | Anonymous -> None
-    | Name id' when id_ord id id' = 0 -> None
-    | Name id' -> Some id'
-  in
-  (* move the rel context to a named context and extend the named instance *)
-  (* with vars of the rel context *)
-  (* We do keep the instances corresponding to local definition (see above) *)
-  let (subst, vsubst, _, env) =
-    Context.Rel.fold_outside
-      (fun decl (subst, vsubst, avoid, env) ->
-        let open Context.Rel.Declaration in
-        let na = get_name decl in
-	let c = get_value decl in
-	let t = get_type decl in
-        let open Context.Named.Declaration in
-        let id =
-          (* ppedrot: we want to infer nicer names for the refine tactic, but
-             keeping at the same time backward compatibility in other code
-             using this function. For now, we only attempt to preserve the
-             old behaviour of Program, but ultimately, one should do something
-             about this whole name generation problem. *)
-          if Flags.is_program_mode () then next_name_away na avoid
-          else next_ident_away (id_of_name_using_hdchar env t na) avoid
-        in
-        match extract_if_neq id na with
-        | Some id0 when not (is_section_variable id0) ->
-            (* spiwack: if [id<>id0], rather than introducing a new
-               binding named [id], we will keep [id0] (the name given
-               by the user) and rename [id0] into [id] in the named
-               context. Unless [id] is a section variable. *)
-            let subst = List.map (replace_vars [id0,mkVar id]) subst in
-            let vsubst = (id0,mkVar id)::vsubst in
-            let d = match c with
-              | None -> LocalAssum (id0, subst2 subst vsubst t)
-              | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t)
-            in
-            let env = replace_var_named_context id0  id env in
-            (mkVar id0 :: subst, vsubst, id::avoid, push_named d env)
-        | _ ->
-            (* spiwack: if [id0] is a section variable renaming it is
-               incorrect. We revert to a less robust behaviour where
-               the new binder has name [id]. Which amounts to the same
-               behaviour than when [id=id0]. *)
-            let d = match c with
-              | None -> LocalAssum (id, subst2 subst vsubst t)
-              | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t)
-            in
-	    (mkVar id :: subst, vsubst, id::avoid, push_named d env)
-      )
-      (rel_context env) ~init:([], [], ids, env) in
-  (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
-
-(*------------------------------------*
- * Entry points to define new evars   *
- *------------------------------------*)
-
-let default_source = (Loc.ghost,Evar_kinds.InternalHole)
-
-let restrict_evar evd evk filter candidates =
-  let evd = Sigma.to_evar_map evd in
-  let evd, evk' = Evd.restrict evk filter ?candidates evd in
-  Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd)
-
-let new_pure_evar_full evd evi =
-  let evd = Sigma.to_evar_map evd in
-  let (evd, evk) = Evd.new_evar evd evi in
-  let evd = Evd.declare_future_goal evk evd in
-  Sigma.Unsafe.of_pair (evk, evd)
-
-let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
-  let evd = Sigma.to_evar_map evd in
-  let default_naming = Misctypes.IntroAnonymous in
-  let naming = Option.default default_naming naming in
-  let evi = {
-    evar_hyps = sign;
-    evar_concl = typ;
-    evar_body = Evar_empty;
-    evar_filter = filter;
-    evar_source = src;
-    evar_candidates = candidates;
-    evar_extra = store; }
-  in
-  let (evd, newevk) = Evd.new_evar evd ~naming evi in
-  let evd =
-    if principal then Evd.declare_principal_goal newevk evd
-    else Evd.declare_future_goal newevk evd
-  in
-  Sigma.Unsafe.of_pair (newevk, evd)
-
-let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance =
-  assert (not !Flags.debug ||
-            List.distinct (ids_of_named_context (named_context_of_val sign)));
-  let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
-  Sigma (mkEvar (newevk,Array.of_list instance), evd, p)
-
-(* [new_evar] declares a new existential in an env env with type typ *)
-(* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
-  let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
-  let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
-  let instance =
-    match filter with
-    | None -> instance
-    | Some filter -> Filter.filter_list filter instance in
-  new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
-
-let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
-  let evd = Sigma.Unsafe.of_evar_map evd in
-  let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
-  (Sigma.to_evar_map evd, evk)
-
-let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
-  let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in
-  let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
-  Sigma ((e, s), evd', p +> q)
-
-let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
-  let sigma = Sigma.Unsafe.of_evar_map !evdref in
-  let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in
-  let sigma = Sigma.to_evar_map sigma in
-    evdref := sigma;
-    c
-
-let new_Type ?(rigid=Evd.univ_flexible) env evd = 
-  let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in
-  Sigma (mkSort s, sigma, p)
-
-let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
-  let evd', s = new_sort_variable rigid !evdref in
-    evdref := evd'; mkSort s
-
-  (* The same using side-effect *)
-let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
-  let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
-  evdref := evd';
-  ev
-
-(* This assumes an evar with identity instance and generalizes it over only
-   the De Bruijn part of the context *)
-let generalize_evar_over_rels sigma (ev,args) =
-  let evi = Evd.find sigma ev in
-  let sign = named_context_of_val evi.evar_hyps in
-  List.fold_left2
-    (fun (c,inst as x) a d ->
-      if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
-     (evi.evar_concl,[]) (Array.to_list args) sign
-
-(************************************)
-(* Removing a dependency in an evar *)
-(************************************)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-let cleared = Store.field ()
-
-exception Depends of Id.t
-
-let rec check_and_clear_in_constr env evdref err ids c =
-  (* returns a new constr where all the evars have been 'cleaned'
-     (ie the hypotheses ids have been removed from the contexts of
-     evars) *)
-  let check id' =
-    if Id.Set.mem id' ids then
-      raise (ClearDependencyError (id',err))
-  in
-    match kind_of_term c with
-      | Var id' ->
-	  check id'; c
-
-      | ( Const _ | Ind _ | Construct _ ) ->
-          let vars = Environ.vars_of_global env c in
-            Id.Set.iter check vars; c
-
-      | Evar (evk,l as ev) ->
-	  if Evd.is_defined !evdref evk then
-	    (* If evk is already defined we replace it by its definition *)
-	    let nc = whd_evar !evdref c in
-	      (check_and_clear_in_constr env evdref err ids nc)
-	  else
-	    (* We check for dependencies to elements of ids in the
-	       evar_info corresponding to e and in the instance of
-	       arguments. Concurrently, we build a new evar
-	       corresponding to e where hypotheses of ids have been
-	       removed *)
-	    let evi = Evd.find_undefined !evdref evk in
-	    let ctxt = Evd.evar_filtered_context evi in
-	    let (rids,filter) =
-              List.fold_right2
-                (fun h a (ri,filter) ->
-                  try
-                  (* Check if some id to clear occurs in the instance
-                     a of rid in ev and remember the dependency *)
-                    let check id = if Id.Set.mem id ids then raise (Depends id) in
-                    let () = Id.Set.iter check (collect_vars a) in
-                  (* Check if some rid to clear in the context of ev
-                     has dependencies in another hyp of the context of ev
-                     and transitively remember the dependency *)
-                    let check id _ =
-                      if occur_var_in_decl (Global.env ()) id h
-                      then raise (Depends id)
-                    in
-                    let () = Id.Map.iter check ri in
-                  (* No dependency at all, we can keep this ev's context hyp *)
-                    (ri, true::filter)
-                  with Depends id -> let open Context.Named.Declaration in
-                                     (Id.Map.add (get_id h) id ri, false::filter))
-		ctxt (Array.to_list l) (Id.Map.empty,[]) in
-	    (* Check if some rid to clear in the context of ev has dependencies
-	       in the type of ev and adjust the source of the dependency *)
-	    let _nconcl =
-	      try
-                let nids = Id.Map.domain rids in
-                check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi)
-	      with ClearDependencyError (rid,err) ->
-		raise (ClearDependencyError (Id.Map.find rid rids,err)) in
-
-            if Id.Map.is_empty rids then c
-            else
-              let origfilter = Evd.evar_filter evi in
-              let filter = Evd.Filter.apply_subfilter origfilter filter in
-              let evd = Sigma.Unsafe.of_evar_map !evdref in
-              let Sigma (_, evd, _) = restrict_evar evd evk filter None in
-              let evd = Sigma.to_evar_map evd in
-              evdref := evd;
-	    (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
-	      let evi = Evd.find !evdref evk in
-	      let extra = evi.evar_extra in
-	      let extra' = Store.set extra cleared true in
-	      let evi' = { evi with evar_extra = extra' } in
-	      evdref := Evd.add !evdref evk evi' ;
-	    (* spiwack: /hacking session *)
-              whd_evar !evdref c
-
-      | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
-
-let clear_hyps_in_evi_main env evdref hyps terms ids =
-  (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
-     hypothesis does not depend on a element of ids, and erases ids in
-     the contexts of the evars occurring in evi *)
-  let terms =
-    List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
-  let nhyps =
-    let open Context.Named.Declaration in
-    let check_context decl =
-      let err = OccurHypInSimpleClause (Some (get_id decl)) in
-      map_constr (check_and_clear_in_constr env evdref err ids) decl
-    in
-    let check_value vk = match force_lazy_val vk with
-    | None -> vk
-    | Some (_, d) ->
-      if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then
-        (* v does depend on any of ids, it's ok *)
-        vk
-      else
-        (* v depends on one of the cleared hyps:
-            we forget the computed value *)
-        dummy_lazy_val ()
-    in
-      remove_hyps ids check_context check_value hyps
-  in
-  (nhyps,terms)
-
-let clear_hyps_in_evi env evdref hyps concl ids =
-  match clear_hyps_in_evi_main env evdref hyps [concl] ids with
-  | (nhyps,[nconcl]) -> (nhyps,nconcl)
-  | _ -> assert false
-
-let clear_hyps2_in_evi env evdref hyps t concl ids =
-  match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with
-  | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl)
-  | _ -> assert false
-
-(* spiwack: a few functions to gather evars on which goals depend. *)
-let queue_set q is_dependent set =
-  Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set
-let queue_term q is_dependent c =
-  queue_set q is_dependent (evars_of_term c)
-
-let process_dependent_evar q acc evm is_dependent e =
-  let evi = Evd.find evm e in
-  (* Queues evars appearing in the types of the goal (conclusion, then
-     hypotheses), they are all dependent. *)
-  queue_term q true evi.evar_concl;
-  List.iter begin fun decl ->
-    let open Context.Named.Declaration in
-    queue_term q true (get_type decl);
-    match decl with
-    | LocalAssum _ -> ()
-    | LocalDef (_,b,_) -> queue_term q true b
-  end (Environ.named_context_of_val evi.evar_hyps);
-  match evi.evar_body with
-  | Evar_empty ->
-      if is_dependent then Evar.Map.add e None acc else acc
-  | Evar_defined b ->
-      let subevars = evars_of_term b in
-      (* evars appearing in the definition of an evar [e] are marked
-         as dependent when [e] is dependent itself: if [e] is a
-         non-dependent goal, then, unless they are reach from another
-         path, these evars are just other non-dependent goals. *)
-      queue_set q is_dependent subevars;
-      if is_dependent then Evar.Map.add e (Some subevars) acc else acc
-
-let gather_dependent_evars q evm =
-  let acc = ref Evar.Map.empty in
-  while not (Queue.is_empty q) do
-    let (is_dependent,e) = Queue.pop q in
-    (* checks if [e] has already been added to [!acc] *)
-    begin if not (Evar.Map.mem e !acc) then
-        acc := process_dependent_evar q !acc evm is_dependent e  
-    end
-  done;
-  !acc
-
-let gather_dependent_evars evm l =
-  let q = Queue.create () in
-  List.iter (fun a -> Queue.add (false,a) q) l;
-  gather_dependent_evars q evm
-
-(* /spiwack *)
-
-(** The following functions return the set of undefined evars
-    contained in the object, the defined evars being traversed.
-    This is roughly a combination of the previous functions and
-    [nf_evar]. *)
-
-let undefined_evars_of_term evd t =
-  let rec evrec acc c =
-    match kind_of_term c with
-      | Evar (n, l) ->
-	let acc = Array.fold_left evrec acc l in
-	(try match (Evd.find evd n).evar_body with
-	  | Evar_empty -> Evar.Set.add n acc
-	  | Evar_defined c -> evrec acc c
-	 with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found"))
-      | _ -> fold_constr evrec acc c
-  in
-  evrec Evar.Set.empty t
-
-let undefined_evars_of_named_context evd nc =
-  let open Context.Named.Declaration in
-  Context.Named.fold_outside
-    (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c)))
-    nc
-    ~init:Evar.Set.empty
-
-let undefined_evars_of_evar_info evd evi =
-  Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
-    (Evar.Set.union
-       (match evi.evar_body with
-	 | Evar_empty -> Evar.Set.empty
-	 | Evar_defined b -> undefined_evars_of_term evd b)
-       (undefined_evars_of_named_context evd
-	  (named_context_of_val evi.evar_hyps)))
-
-(* spiwack: this is a more complete version of
-   {!Termops.occur_evar}. The latter does not look recursively into an
-   [evar_map]. If unification only need to check superficially, tactics
-   do not have this luxury, and need the more complete version. *)
-let occur_evar_upto sigma n c =
-  let rec occur_rec c = match kind_of_term c with
-    | Evar (sp,_) when Evar.equal sp n -> raise Occur
-    | Evar e -> Option.iter occur_rec (existential_opt_value sigma e)
-    | _ -> iter_constr occur_rec c
-  in
-  try occur_rec c; false with Occur -> true
-
-(* We don't try to guess in which sort the type should be defined, since
-   any type has type Type. May cause some trouble, but not so far... *)
-
-let judge_of_new_Type evd =
-  let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in
-  Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p)
-
-let subterm_source evk (loc,k) =
-  let evk = match k with
-    | Evar_kinds.SubEvar (evk) -> evk
-    | _ -> evk in
-  (loc,Evar_kinds.SubEvar evk)
-
-
-(** Term exploration up to instantiation. *)
-let kind_of_term_upto sigma t =
-  Constr.kind (whd_evar sigma t)
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
-    [u] up to existential variable instantiation and equalisable
-    universes. The term [t] is interpreted in [sigma1] while [u] is
-    interpreted in [sigma2]. The universe constraints in [sigma2] are
-    assumed to be an extention of those in [sigma1]. *)
-let eq_constr_univs_test sigma1 sigma2 t u =
-  (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
-  let open Evd in
-  let fold cstr sigma =
-    try Some (add_universe_constraints sigma cstr)
-    with Univ.UniverseInconsistency _ | UniversesDiffer -> None
-  in
-  let ans =
-    Universes.eq_constr_univs_infer_with
-      (fun t -> kind_of_term_upto sigma1 t)
-      (fun u -> kind_of_term_upto sigma2 u)
-      (universes sigma2) fold t u sigma2
-  in
-  match ans with None -> false | Some _ -> true
-
-type type_constraint = types option
-type val_constraint = constr option
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
deleted file mode 100644
index ffff2c5dd9..0000000000
--- a/pretyping/evarutil.mli
+++ /dev/null
@@ -1,221 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-open Evd
-open Environ
-
-(** {5 This modules provides useful functions for unification modulo evars } *)
-
-(** {6 Metas} *)
-
-(** [new_meta] is a generator of unique meta variables *)
-val new_meta : unit -> metavariable
-val mk_new_meta : unit -> constr
-
-(** {6 Creating a fresh evar given their type and context} *)
-val new_evar :
-  env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
-  ?candidates:constr list -> ?store:Store.t ->
-  ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool -> types -> (constr, 'r) Sigma.sigma
-
-val new_pure_evar :
-  named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
-  ?candidates:constr list -> ?store:Store.t ->
-  ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool -> types -> (evar, 'r) Sigma.sigma
-
-val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma
-
-(** the same with side-effects *)
-val e_new_evar :
-  env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
-  ?candidates:constr list -> ?store:Store.t ->
-  ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool -> types -> constr
-
-(** Create a new Type existential variable, as we keep track of 
-    them during type-checking and unification. *)
-val new_type_evar :
-  env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
-  ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
-  (constr * sorts, 'r) Sigma.sigma
-
-val e_new_type_evar : env -> evar_map ref ->
-  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
-  ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts
-
-val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma
-val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr
-
-val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t ->
-  constr list option -> (existential_key, 'r) Sigma.sigma
-
-(** Polymorphic constants *)
-
-val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma
-val e_new_global : evar_map ref -> Globnames.global_reference -> constr
-
-(** Create a fresh evar in a context different from its definition context:
-   [new_evar_instance sign evd ty inst] creates a new evar of context
-   [sign] and type [ty], [inst] is a mapping of the evar context to
-   the context where the evar should occur. This means that the terms
-   of [inst] are typed in the occurrence context and their type (seen
-   as a telescope) is [sign] *)
-val new_evar_instance :
- named_context_val -> 'r Sigma.t -> types -> 
-  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list ->
-  ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
-  ?principal:bool ->
-  constr list -> (constr, 'r) Sigma.sigma
-
-val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
-
-val safe_evar_value : evar_map -> existential -> constr option
-
-(** {6 Evars/Metas switching...} *)
-
-val non_instantiated : evar_map -> evar_info Evar.Map.t
-
-(** {6 Unification utils} *)
-
-(** [head_evar c] returns the head evar of [c] if any *)
-exception NoHeadEvar
-val head_evar : constr -> existential_key (** may raise NoHeadEvar *)
-
-(* Expand head evar if any *)
-val whd_head_evar :  evar_map -> constr -> constr
-
-(* An over-approximation of [has_undefined (nf_evars evd c)] *)
-val has_undefined_evars : evar_map -> constr -> bool
-
-val is_ground_term :  evar_map -> constr -> bool
-val is_ground_env  :  evar_map -> env -> bool
-
-(** [gather_dependent_evars evm seeds] classifies the evars in [evm]
-    as dependent_evars and goals (these may overlap). A goal is an
-    evar in [seeds] or an evar appearing in the (partial) definition
-    of a goal. A dependent evar is an evar appearing in the type
-    (hypotheses and conclusion) of a goal, or in the type or (partial)
-    definition of a dependent evar.  The value return is a map
-    associating to each dependent evar [None] if it has no (partial)
-    definition or [Some s] if [s] is the list of evars appearing in
-    its (partial) definition. *)
-val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t
-
-(** The following functions return the set of undefined evars
-    contained in the object, the defined evars being traversed.
-    This is roughly a combination of the previous functions and
-    [nf_evar]. *)
-
-val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
-val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t
-val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
-
-(** [occur_evar_upto sigma k c] returns [true] if [k] appears in
-    [c]. It looks up recursively in [sigma] for the value of existential
-    variables. *)
-val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
-
-(** {6 Value/Type constraints} *)
-
-val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma
-
-(***********************************************************)
-
-(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
-    uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
-
-val whd_evar :  evar_map -> constr -> constr
-val nf_evar :  evar_map -> constr -> constr
-val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
-   evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
-   evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
-   evar_map -> unsafe_type_judgment -> unsafe_type_judgment
-
-val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t
-val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t
-val nf_env_evar : evar_map -> env -> env
-
-val nf_evar_info : evar_map -> evar_info -> evar_info
-val nf_evar_map : evar_map -> evar_map
-val nf_evar_map_undefined : evar_map -> evar_map
-
-(** Presenting terms without solved evars *)
-
-val nf_evars_universes : evar_map -> constr -> constr
-
-val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr)
-val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst
-
-(** Normalize the evar map w.r.t. universes, after simplification of constraints.
-    Return the substitution function for constrs as well. *)
-val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr)
-
-(** Replacing all evars, possibly raising [Uninstantiated_evar] *)
-exception Uninstantiated_evar of existential_key
-val flush_and_check_evars :  evar_map -> constr -> constr
-
-(** {6 Term manipulation up to instantiation} *)
-
-(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t]
-    as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the
-    value of [e] in [sigma] is (recursively) used. *)
-val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
-    [u] up to existential variable instantiation and equalisable
-    universes. The term [t] is interpreted in [sigma1] while [u] is
-    interpreted in [sigma2]. The universe constraints in [sigma2] are
-    assumed to be an extention of those in [sigma1]. *)
-val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool
-
-(** {6 Removing hyps in evars'context}
-raise OccurHypInSimpleClause if the removal breaks dependencies *)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-(* spiwack: marks an evar that has been "defined" by clear.
-    used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
-val cleared : bool Store.field
-
-val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types ->
-  Id.Set.t -> named_context_val * types
-
-val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types ->
-  Id.Set.t -> named_context_val * types * types
-
-val push_rel_context_to_named_context : Environ.env -> types ->
-  named_context_val * types * constr list * constr list * (identifier*constr) list
-
-val generalize_evar_over_rels : evar_map -> existential -> types * constr list
-
-(** Evar combinators *)
-
-val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a
-val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a
-val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a
-
-val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
-  Evar_kinds.t Loc.located
-
-val meta_counter_summary_name : string
-
-(** Deprecater *)
-
-type type_constraint = types option
-type val_constraint = constr option
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index be517d1aa0..c8b3307d76 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,6 +1,5 @@
 Locusops
 Pretype_errors
-Evarutil
 Reductionops
 Inductiveops
 Vnorm
@@ -21,7 +20,6 @@ Patternops
 Constr_matching
 Tacred
 Typeclasses_errors
-Proofview
 Typeclasses
 Classops
 Program
diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml
deleted file mode 100644
index ba664cafaf..0000000000
--- a/pretyping/proofview.ml
+++ /dev/null
@@ -1,1211 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-
-(** This files defines the basic mechanism of proofs: the [proofview]
-    type is the state which tactics manipulate (a global state for
-    existential variables, together with the list of goals), and the type
-    ['a tactic] is the (abstract) type of tactics modifying the proof
-    state and returning a value of type ['a]. *)
-
-open Pp
-open Util
-open Proofview_monad
-open Sigma.Notations
-open Context.Named.Declaration
-
-(** Main state of tactics *)
-type proofview = Proofview_monad.proofview
-
-type entry = (Term.constr * Term.types) list
-
-(** Returns a stylised view of a proofview for use by, for instance,
-    ide-s. *)
-(* spiwack: the type of [proofview] will change as we push more
-   refined functions to ide-s. This would be better than spawning a
-   new nearly identical function everytime. Hence the generic name. *)
-(* In this version: returns the list of focused goals together with
-   the [evar_map] context. *)
-let proofview p =
-  p.comb , p.solution
-
-let compact el ({ solution } as pv) =
-  let nf = Evarutil.nf_evar solution in
-  let size = Evd.fold (fun _ _ i -> i+1) solution 0 in
-  let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in
-  let pruned_solution = Evd.drop_all_defined solution in
-  let apply_subst_einfo _ ei =
-    Evd.({ ei with
-       evar_concl =  nf ei.evar_concl;
-       evar_hyps = Environ.map_named_val nf ei.evar_hyps;
-       evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in
-  let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in
-  let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in
-  msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
-  new_el, { pv with solution = new_solution; }
-
-
-(** {6 Starting and querying a proof view} *)
-
-type telescope =
-  | TNil of Evd.evar_map
-  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
-
-let typeclass_resolvable = Evd.Store.field ()
-
-let dependent_init =
-  (* Goals are created with a store which marks them as unresolvable
-     for type classes. *)
-  let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in
-  (* Goals don't have a source location. *)
-  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
-  (* Main routine *)
-  let rec aux = function
-  | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] }
-  | TCons (env, sigma, typ, t) ->
-    let sigma = Sigma.Unsafe.of_evar_map sigma in
-    let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in
-    let sigma = Sigma.to_evar_map sigma in
-    let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
-    let (gl, _) = Term.destEvar econstr in
-    let entry = (econstr, typ) :: ret in
-    entry, { solution = sol; comb = gl :: comb; shelf = [] }
-  in
-  fun t ->
-    let entry, v = aux t in
-    (* The created goal are not to be shelved. *)
-    let solution = Evd.reset_future_goals v.solution in
-    entry, { v with solution }
-
-let init =
-  let rec aux sigma = function
-    | [] -> TNil sigma
-    | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l))
-  in
-  fun sigma l -> dependent_init (aux sigma l)
-
-let initial_goals initial = initial
-
-let finished = function
-  | {comb = []} -> true
-  | _  -> false
-
-let return { solution=defs } = defs
-
-let return_constr { solution = defs } c = Evarutil.nf_evar defs c
-
-let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry)
-
-
-(** {6 Focusing commands} *)
-
-(** A [focus_context] represents the part of the proof view which has
-    been removed by a focusing action, it can be used to unfocus later
-    on. *)
-(* First component is a reverse list of the goals which come before
-   and second component is the list of the goals which go after (in
-   the expected order). *)
-type focus_context = Evar.t list * Evar.t list
-
-
-(** Returns a stylised view of a focus_context for use by, for
-    instance, ide-s. *)
-(* spiwack: the type of [focus_context] will change as we push more
-   refined functions to ide-s. This would be better than spawning a
-   new nearly identical function everytime. Hence the generic name. *)
-(* In this version: the goals in the context, as a "zipper" (the first
-   list is in reversed order). *)
-let focus_context f = f
-
-(** This (internal) function extracts a sublist between two indices,
-    and returns this sublist together with its context: if it returns
-    [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
-    original list.  The focused list has lenght [j-i-1] and contains
-    the goals from number [i] to number [j] (both included) the first
-    goal of the list being numbered [1].  [focus_sublist i j l] raises
-    [IndexOutOfRange] if [i > length l], or [j > length l] or [j <
-    i]. *)
-let focus_sublist i j l =
-  let (left,sub_right) = CList.goto (i-1) l in
-  let (sub, right) = 
-    try CList.chop (j-i+1) sub_right
-    with Failure _ -> raise CList.IndexOutOfRange
-  in
-  (sub, (left,right))
-
-(** Inverse operation to the previous one. *)
-let unfocus_sublist (left,right) s =
-  CList.rev_append left (s@right)
-
-
-(** [focus i j] focuses a proofview on the goals from index [i] to
-    index [j] (inclusive, goals are indexed from [1]). I.e. goals
-    number [i] to [j] become the only focused goals of the returned
-    proofview.  It returns the focused proofview, and a context for
-    the focus stack. *)
-let focus i j sp =
-  let (new_comb, context) = focus_sublist i j sp.comb in
-  ( { sp with comb = new_comb } , context )
-
-
-(** [advance sigma g] returns [Some g'] if [g'] is undefined and is
-    the current avatar of [g] (for instance [g] was changed by [clear]
-    into [g']). It returns [None] if [g] has been (partially)
-    solved. *)
-(* spiwack: [advance] is probably performance critical, and the good
-   behaviour of its definition may depend sensitively to the actual
-   definition of [Evd.find]. Currently, [Evd.find] starts looking for
-   a value in the heap of undefined variable, which is small. Hence in
-   the most common case, where [advance] is applied to an unsolved
-   goal ([advance] is used to figure if a side effect has modified the
-   goal) it terminates quickly. *)
-let rec advance sigma g =
-  let open Evd in
-  let evi = Evd.find sigma g in
-  match evi.evar_body with
-  | Evar_empty -> Some g
-  | Evar_defined v ->
-      if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then
-        let (e,_) = Term.destEvar v in
-        advance sigma e
-      else
-        None
-
-(** [undefined defs l] is the list of goals in [l] which are still
-    unsolved (after advancing cleared goals). *)
-let undefined defs l = CList.map_filter (advance defs) l
-
-(** Unfocuses a proofview with respect to a context. *)
-let unfocus c sp =
-  { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) }
-
-
-(** {6 The tactic monad} *)
-
-(** - Tactics are objects which apply a transformation to all the
-    subgoals of the current view at the same time. By opposition to
-    the old vision of applying it to a single goal. It allows tactics
-    such as [shelve_unifiable], tactics to reorder the focused goals,
-    or global automation tactic for dependent subgoals (instantiating
-    an evar has influences on the other goals of the proof in
-    progress, not being able to take that into account causes the
-    current eauto tactic to fail on some instances where it could
-    succeed).  Another benefit is that it is possible to write tactics
-    that can be executed even if there are no focused goals.
-    - Tactics form a monad ['a tactic], in a sense a tactic can be
-    seen as a function (without argument) which returns a value of
-    type 'a and modifies the environment (in our case: the view).
-    Tactics of course have arguments, but these are given at the
-    meta-level as OCaml functions.  Most tactics in the sense we are
-    used to return [()], that is no really interesting values. But
-    some might pass information around.  The tactics seen in Coq's
-    Ltac are (for now at least) only [unit tactic], the return values
-    are kept for the OCaml toolkit.  The operation or the monad are
-    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
-    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
-    (which is a specialized bind on unit-returning tactics).
-    - Tactics have support for full-backtracking. Tactics can be seen
-    having multiple success: if after returning the first success a
-    failure is encountered, the tactic can backtrack and use a second
-    success if available. The state is backtracked to its previous
-    value, except the non-logical state defined in the {!NonLogical}
-    module below.
-*)
-(* spiwack: as far as I'm aware this doesn't really relate to
-   F. Kirchner and C. Muñoz. *)
-
-module Proof = Logical
-
-(** type of tactics:
-
-   tactics can
-   - access the environment,
-   - report unsafe status, shelved goals and given up goals
-   - access and change the current [proofview]
-   - backtrack on previous changes of the proofview *)
-type +'a tactic = 'a Proof.t
-
-(** Applies a tactic to the current proofview. *)
-let apply env t sp =
-  let open Logic_monad in
-  let ans = Proof.repr (Proof.run t false (sp,env)) in
-  let ans = Logic_monad.NonLogical.run ans in
-  match ans with
-  | Nil (e, info) -> iraise (TacticFailure e, info)
-  | Cons ((r, (state, _), status, info), _) ->
-    let (status, gaveup) = status in
-    let status = (status, state.shelf, gaveup) in
-    let state = { state with shelf = [] } in
-    r, state, status, Trace.to_tree info
-
-
-
-(** {7 Monadic primitives} *)
-
-(** Unit of the tactic monad. *)
-let tclUNIT = Proof.return
-
-(** Bind operation of the tactic monad. *)
-let tclBIND = Proof.(>>=)
-
-(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation,
-    it's a specialized "bind". *)
-let tclTHEN = Proof.(>>)
-
-(** [tclIGNORE t] has the same operational content as [t], but drops
-    the returned value. *)
-let tclIGNORE = Proof.ignore
-
-module Monad = Proof
-
-
-
-(** {7 Failure and backtracking} *)
-
-
-(** [tclZERO e] fails with exception [e]. It has no success. *)
-let tclZERO ?info e =
-  let info = match info with
-  | None -> Exninfo.null
-  | Some info -> info
-  in
-  Proof.zero (e, info)
-
-(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
-    the successes of [t1] have been depleted and it failed with [e],
-    then it behaves as [t2 e]. In other words, [tclOR] inserts a
-    backtracking point. *)
-let tclOR = Proof.plus
-
-(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
-    success or [t2 e] if [t1] fails with [e]. It is analogous to
-    [try/with] handler of exception in that it is not a backtracking
-    point. *)
-let tclORELSE t1 t2 =
-  let open Logic_monad in
-  let open Proof in
-  split t1 >>= function
-    | Nil e -> t2 e
-    | Cons (a,t1') -> plus (return a) t1'
-
-(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
-    succeeds at least once then it behaves as [tclBIND a s] otherwise,
-    if [a] fails with [e], then it behaves as [f e]. *)
-let tclIFCATCH a s f =
-  let open Logic_monad in
-  let open Proof in
-  split a >>= function
-    | Nil e -> f e
-    | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x'))
-
-(** [tclONCE t] behave like [t] except it has at most one success:
-    [tclONCE t] stops after the first success of [t]. If [t] fails
-    with [e], [tclONCE t] also fails with [e]. *)
-let tclONCE = Proof.once
-
-exception MoreThanOneSuccess
-let _ = Errors.register_handler begin function
-  | MoreThanOneSuccess -> Errors.error "This tactic has more than one success."
-  | _ -> raise Errors.Unhandled
-end
-
-(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
-    success. Otherwise it fails. The tactic [t] is run until its first
-    success, then a failure with exception [e] is simulated. It [t]
-    yields another success, then [tclEXACTLY_ONCE e t] fails with
-    [MoreThanOneSuccess] (it is a user error). Otherwise,
-    [tclEXACTLY_ONCE e t] succeeds with the first success of
-    [t]. Notice that the choice of [e] is relevant, as the presence of
-    further successes may depend on [e] (see {!tclOR}). *)
-let tclEXACTLY_ONCE e t =
-  let open Logic_monad in
-  let open Proof in
-  split t >>= function
-    | Nil (e, info) -> tclZERO ~info e
-    | Cons (x,k) ->
-        Proof.split (k (e, Exninfo.null)) >>= function
-          | Nil _ -> tclUNIT x
-          | _ -> tclZERO MoreThanOneSuccess
-
-
-(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *)
-type 'a case =
-| Fail of iexn
-| Next of 'a * (iexn -> 'a tactic)
-let tclCASE t =
-  let open Logic_monad in
-  let map = function
-  | Nil e -> Fail e
-  | Cons (x, t) -> Next (x, t)
-  in
-  Proof.map map (Proof.split t)
-
-let tclBREAK = Proof.break
-
-
-
-(** {7 Focusing tactics} *)
-
-exception NoSuchGoals of int
-
-(* This hook returns a string to be appended to the usual message.
-   Primarily used to add a suggestion about the right bullet to use to
-   focus the next goal, if applicable. *)
-let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ())
-let set_nosuchgoals_hook f = nosuchgoals_hook := f
-
-
-
-(* This uses the hook above *)
-let _ = Errors.register_handler begin function
-  | NoSuchGoals n ->
-    let suffix = !nosuchgoals_hook n in
-    Errors.errorlabstrm ""
-      (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix)
-  | _ -> raise Errors.Unhandled
-end
-
-(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where
-    only the goals numbered [i] to [j] are focused (the rest of the goals
-    is restored at the end of the tactic). If the range [i]-[j] is not
-    valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *)
-let tclFOCUS_gen nosuchgoal i j t =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  try
-    let (focused,context) = focus i j initial in
-    Pv.set focused >>
-    t >>= fun result ->
-    Pv.modify (fun next -> unfocus context next) >>
-    return result
-  with CList.IndexOutOfRange -> nosuchgoal
-
-let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t
-let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t
-
-(** Like {!tclFOCUS} but selects a single goal by name. *)
-let tclFOCUSID id t =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  try
-    let ev = Evd.evar_key id initial.solution in
-    try
-      let n = CList.index Evar.equal ev initial.comb in
-      (* goal is already under focus *)
-      let (focused,context) = focus n n initial in
-      Pv.set focused >>
-        t >>= fun result ->
-      Pv.modify (fun next -> unfocus context next) >>
-        return result
-    with Not_found ->
-      (* otherwise, save current focus and work purely on the shelve *)
-      Comb.set [ev] >>
-        t >>= fun result ->
-      Comb.set initial.comb  >>
-        return result
-  with Not_found -> tclZERO (NoSuchGoals 1)
-
-(** {7 Dispatching on goals} *)
-
-exception SizeMismatch of int*int
-let _ = Errors.register_handler begin function
-  | SizeMismatch (i,_) ->
-      let open Pp in
-      let errmsg =
-        str"Incorrect number of goals" ++ spc() ++
-        str"(expected "++int i++str(String.plural i " tactic") ++ str")."
-      in
-      Errors.errorlabstrm "" errmsg
-  | _ -> raise Errors.Unhandled
-end
-
-(** A variant of [Monad.List.iter] where we iter over the focused list
-    of goals. The argument tactic is executed in a focus comprising
-    only of the current goal, a goal which has been solved by side
-    effect is skipped. The generated subgoals are concatenated in
-    order.  *)
-let iter_goal i =
-  let open Proof in
-  Comb.get >>= fun initial ->
-  Proof.List.fold_left begin fun (subgoals as cur) goal ->
-    Solution.get >>= fun step ->
-    match advance step goal with
-    | None -> return cur
-    | Some goal ->
-        Comb.set [goal] >>
-        i goal >>
-        Proof.map (fun comb -> comb :: subgoals) Comb.get
-  end [] initial >>= fun subgoals ->
-  Solution.get >>= fun evd ->
-  Comb.set CList.(undefined evd (flatten (rev subgoals)))
-
-(** A variant of [Monad.List.fold_left2] where the first list is the
-    list of focused goals. The argument tactic is executed in a focus
-    comprising only of the current goal, a goal which has been solved
-    by side effect is skipped. The generated subgoals are concatenated
-    in order. *)
-let fold_left2_goal i s l =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  let err =
-    return () >>= fun () -> (* Delay the computation of list lengths. *)
-    tclZERO (SizeMismatch (CList.length initial.comb,CList.length l))
-  in 
-  Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a ->
-    Solution.get >>= fun step ->
-    match advance step goal with
-    | None -> return cur
-    | Some goal ->
-        Comb.set [goal] >>
-        i goal a r >>= fun r ->
-        Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get
-  end (s,[]) initial.comb l >>= fun (r,subgoals) ->
-  Solution.get >>= fun evd ->
-  Comb.set CList.(undefined evd (flatten (rev subgoals))) >>
-  return r
-
-(** Dispatch tacticals are used to apply a different tactic to each
-    goal under focus. They come in two flavours: [tclDISPATCH] takes a
-    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
-    takes a list of ['a tactic] and returns an ['a list tactic].
-
-    They both work by applying each of the tactic in a focus
-    restricted to the corresponding goal (starting with the first
-    goal). In the case of [tclDISPATCHL], the tactic returns a list of
-    the same size as the argument list (of tactics), each element
-    being the result of the tactic executed in the corresponding goal.
-
-    When the length of the tactic list is not the number of goal,
-    raises [SizeMismatch (g,t)] where [g] is the number of available
-    goals, and [t] the number of tactics passed.
-
-    [tclDISPATCHGEN join tacs] generalises both functions as the
-    successive results of [tacs] are stored in reverse order in a
-    list, and [join] is used to convert the result into the expected
-    form. *)
-let tclDISPATCHGEN0 join tacs =
-  match tacs with
-  | [] ->
-      begin 
-        let open Proof in
-        Comb.get >>= function
-        | [] -> tclUNIT (join [])
-        | comb -> tclZERO (SizeMismatch (CList.length comb,0))
-      end
-  | [tac] ->
-      begin
-        let open Proof in
-        Pv.get >>= function
-        | { comb=[goal] ; solution } ->
-            begin match advance solution goal with
-            | None -> tclUNIT (join [])
-            | Some _ -> Proof.map (fun res -> join [res]) tac
-            end
-        | {comb} -> tclZERO (SizeMismatch(CList.length comb,1))
-      end
-  | _ ->
-      let iter _ t cur = Proof.map (fun y -> y :: cur) t in
-      let ans = fold_left2_goal iter [] tacs in
-      Proof.map join ans
-
-let tclDISPATCHGEN join tacs =
-  let branch t = InfoL.tag (Info.DBranch) t in
-  let tacs = CList.map branch tacs in
-  InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs)
-
-let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs
-
-let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs
-
-
-(** [extend_to_list startxs rx endxs l] builds a list
-    [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises
-    [SizeMismatch] if [startxs@endxs] is already longer than [l]. *)
-let extend_to_list startxs rx endxs l =
-  (* spiwack: I use [l] essentially as a natural number *)
-  let rec duplicate acc = function
-    | [] -> acc
-    | _::rest -> duplicate (rx::acc) rest
-  in
-  let rec tail to_match rest =
-    match rest, to_match with
-    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
-    | _::rest , _::to_match -> tail to_match rest
-    | _ , [] -> duplicate endxs rest
-  in
-  let rec copy pref rest =
-    match rest,pref with
-    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
-    | _::rest, a::pref -> a::(copy pref rest)
-    | _ , [] -> tail endxs rest
-  in
-  copy startxs l
-
-(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
-    tactic is "repeated" enough time such that every goal has a tactic
-    assigned to it ([b] is the list of tactics applied to the first
-    goals, [e] to the last goals, and [r] is applied to every goal in
-    between). *)
-let tclEXTEND tacs1 rtac tacs2 =
-  let open Proof in
-  Comb.get >>= fun comb ->
-  try
-    let tacs = extend_to_list tacs1 rtac tacs2 comb in
-    tclDISPATCH tacs
-  with SizeMismatch _ ->
-    tclZERO (SizeMismatch(
-      CList.length comb,
-      (CList.length tacs1)+(CList.length tacs2)))
-(* spiwack: failure occurs only when the number of goals is too
-   small. Hence we can assume that [rtac] is replicated 0 times for
-   any error message. *)
-
-(** [tclEXTEND [] tac []]. *)
-let tclINDEPENDENT tac =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  match initial.comb with
-  | [] -> tclUNIT ()
-  | [_] -> tac
-  | _ ->
-      let tac = InfoL.tag (Info.DBranch) tac in
-      InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac))
-
-
-
-(** {7 Goal manipulation} *)
-
-(** Shelves all the goals under focus. *)
-let shelve =
-  let open Proof in
-  Comb.get >>= fun initial ->
-  Comb.set [] >>
-  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >>
-  Shelf.modify (fun gls -> gls @ initial)
-
-
-(** [contained_in_info e evi] checks whether the evar [e] appears in
-    the hypotheses, the conclusion or the body of the evar_info
-    [evi]. Note: since we want to use it on goals, the body is actually
-    supposed to be empty. *)
-let contained_in_info sigma e evi =
-  Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
-
-(** [depends_on sigma src tgt] checks whether the goal [src] appears
-    as an existential variable in the definition of the goal [tgt] in
-    [sigma]. *)
-let depends_on sigma src tgt =
-  let evi = Evd.find sigma tgt in
-  contained_in_info sigma src evi
-
-(** [unifiable sigma g l] checks whether [g] appears in another
-    subgoal of [l]. The list [l] may contain [g], but it does not
-    affect the result. *)
-let unifiable sigma g l =
-  CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l
-
-(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)]
-    where [u] is composed of the unifiable goals, i.e. the goals on
-    whose definition other goals of [l] depend, and [n] are the
-    non-unifiable goals. *)
-let partition_unifiable sigma l =
-  CList.partition (fun g -> unifiable sigma g l) l
-
-(** Shelves the unifiable goals under focus, i.e. the goals which
-    appear in other goals under focus (the unfocused goals are not
-    considered). *)
-let shelve_unifiable =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  let (u,n) = partition_unifiable initial.solution initial.comb in
-  Comb.set n >>
-  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >>
-  Shelf.modify (fun gls -> gls @ u)
-
-(** [guard_no_unifiable] returns the list of unifiable goals if some
-    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
-let guard_no_unifiable =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  let (u,n) = partition_unifiable initial.solution initial.comb in
-  match u with
-  | [] -> tclUNIT None
-  | gls ->
-      let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in
-      let l = CList.map (fun id -> Names.Name id) l in
-      tclUNIT (Some l)
-
-(** [unshelve l p] adds all the goals in [l] at the end of the focused
-    goals of p *)
-let unshelve l p =
-  (* advance the goals in case of clear *)
-  let l = undefined p.solution l in
-  { p with comb = p.comb@l }
-
-let with_shelf tac =
-  let open Proof in
-  Pv.get >>= fun pv ->
-  let { shelf; solution } = pv in
-  Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >>
-  tac >>= fun ans ->
-  Pv.get >>= fun npv ->
-  let { shelf = gls; solution = sigma } = npv in
-  let gls' = Evd.future_goals sigma in
-  let fgoals = Evd.future_goals solution in
-  let pgoal = Evd.principal_future_goal solution in
-  let sigma = Evd.restore_future_goals sigma fgoals pgoal in
-  Pv.set { npv with shelf; solution = sigma } >>
-  tclUNIT (CList.rev_append gls' gls, ans)
-
-(** [goodmod p m] computes the representative of [p] modulo [m] in the
-    interval [[0,m-1]].*)
-let goodmod p m =
-  let p' = p mod m in
-  (* if [n] is negative [n mod l] is negative of absolute value less
-     than [l], so [(n mod l)+l] is the representative of [n] in the
-     interval [[0,l-1]].*)
-  if p' < 0 then p'+m else p'
-
-let cycle n =
-  let open Proof in
-  InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >>
-  Comb.modify begin fun initial ->
-    let l = CList.length initial in
-    let n' = goodmod n l in
-    let (front,rear) = CList.chop n' initial in
-    rear@front
-  end
-
-let swap i j =
-  let open Proof in
-  InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >>
-  Comb.modify begin fun initial ->
-    let l = CList.length initial in
-    let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in
-    let i = goodmod i l and j = goodmod j l in
-    CList.map_i begin fun k x ->
-      match k with
-      | k when Int.equal k i -> CList.nth initial j
-      | k when Int.equal k j -> CList.nth initial i
-      | _ -> x
-    end 0 initial
-  end
-
-let revgoals =
-  let open Proof in
-  InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >>
-  Comb.modify CList.rev
-
-let numgoals =
-  let open Proof in
-  Comb.get >>= fun comb ->
-  return (CList.length comb)
-
-
-
-(** {7 Access primitives} *)
-
-let tclEVARMAP = Solution.get
-
-let tclENV = Env.get
-
-
-
-(** {7 Put-like primitives} *)
-
-
-let emit_side_effects eff x =
-  { x with solution = Evd.emit_side_effects eff x.solution }
-
-let tclEFFECTS eff =
-  let open Proof in
-  return () >>= fun () -> (* The Global.env should be taken at exec time *)
-  Env.set (Global.env ()) >>
-  Pv.modify (fun initial -> emit_side_effects eff initial)
-
-let mark_as_unsafe = Status.put false
-
-(** Gives up on the goal under focus. Reports an unsafe status. Proofs
-    with given up goals cannot be closed. *)
-let give_up =
-  let open Proof in
-  Comb.get >>= fun initial ->
-  Comb.set [] >>
-  mark_as_unsafe >>
-  InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >>
-  Giveup.put initial
-
-
-
-(** {7 Control primitives} *)
-
-
-module Progress = struct
-
-  let eq_constr = Evarutil.eq_constr_univs_test
-
-  (** equality function on hypothesis contexts *)
-  let eq_named_context_val sigma1 sigma2 ctx1 ctx2 =
-    let open Environ in
-    let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in
-    let eq_named_declaration d1 d2 =
-      match d1, d2 with
-      | LocalAssum (i1,t1), LocalAssum (i2,t2) ->
-         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2
-      | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) ->
-         Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2
-         && eq_constr sigma1 sigma2 t1 t2
-      | _ ->
-         false
-    in List.equal eq_named_declaration c1 c2
-
-  let eq_evar_body sigma1 sigma2 b1 b2 =
-    let open Evd in
-    match b1, b2 with
-    | Evar_empty, Evar_empty -> true
-    | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2
-    | _ -> false
-
-  let eq_evar_info sigma1 sigma2 ei1 ei2 =
-    let open Evd in
-    eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl &&
-    eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) &&
-    eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body
-
-  (** Equality function on goals *)
-  let goal_equal evars1 gl1 evars2 gl2 =
-    let evi1 = Evd.find evars1 gl1 in
-    let evi2 = Evd.find evars2 gl2 in
-    eq_evar_info evars1 evars2 evi1 evi2
-
-end
-
-let tclPROGRESS t =
-  let open Proof in
-  Pv.get >>= fun initial ->
-  t >>= fun res ->
-  Pv.get >>= fun final ->
-  (* [*_test] test absence of progress. [quick_test] is approximate
-     whereas [exhaustive_test] is complete. *)
-  let quick_test =
-    initial.solution == final.solution && initial.comb == final.comb
-  in
-  let exhaustive_test =
-    Util.List.for_all2eq begin fun i f ->
-      Progress.goal_equal initial.solution i final.solution f
-    end initial.comb final.comb
-  in
-  let test =
-    quick_test || exhaustive_test
-  in
-  if not test then
-    tclUNIT res
-  else
-    tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
-
-exception Timeout
-let _ = Errors.register_handler begin function
-  | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
-  | _ -> Pervasives.raise Errors.Unhandled
-end
-
-let tclTIMEOUT n t =
-  let open Proof in
-  (* spiwack: as one of the monad is a continuation passing monad, it
-     doesn't force the computation to be threaded inside the underlying
-     (IO) monad. Hence I force it myself by asking for the evaluation of
-     a dummy value first, lest [timeout] be called when everything has
-     already been computed. *)
-  let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in
-  Proof.get >>= fun initial ->
-  Proof.current >>= fun envvar ->
-  Proof.lift begin
-    Logic_monad.NonLogical.catch
-      begin
-        let open Logic_monad.NonLogical in
-        timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
-        match r with
-        | Logic_monad.Nil e -> return (Util.Inr e)
-        | Logic_monad.Cons (r, _) -> return (Util.Inl r)
-      end
-      begin let open Logic_monad.NonLogical in function (e, info) ->
-        match e with
-        | Logic_monad.Timeout -> return (Util.Inr (Timeout, info))
-        | Logic_monad.TacticFailure e ->
-          return (Util.Inr (e, info))
-        | e -> Logic_monad.NonLogical.raise ~info e
-      end
-  end >>= function
-    | Util.Inl (res,s,m,i) ->
-        Proof.set s >>
-        Proof.put m >>
-        Proof.update (fun _ -> i) >>
-        return res
-    | Util.Inr (e, info) -> tclZERO ~info e
-
-let tclTIME s t =
-  let pr_time t1 t2 n msg =
-    let msg =
-      if n = 0 then
-        str msg
-      else
-        str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking")
-    in
-    msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++
-             System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in
-  let rec aux n t =
-    let open Proof in
-    tclUNIT () >>= fun () ->
-    let tstart = System.get_time() in
-    Proof.split t >>= let open Logic_monad in function
-    | Nil (e, info) ->
-      begin
-        let tend = System.get_time() in
-        pr_time tstart tend n "failure";
-        tclZERO ~info e
-      end
-    | Cons (x,k) ->
-        let tend = System.get_time() in
-        pr_time tstart tend n "success";
-        tclOR (tclUNIT x) (fun e -> aux (n+1) (k e))
-  in aux 0 t
-
-
-
-(** {7 Unsafe primitives} *)
-
-module Unsafe = struct
-
-  let tclEVARS evd =
-    Pv.modify (fun ps -> { ps with solution = evd })
-
-  let tclNEWGOALS gls =
-    Pv.modify begin fun step ->
-      let gls = undefined step.solution gls in
-      { step with comb = step.comb @ gls }
-    end
-
-  let tclGETGOALS = Comb.get
-
-  let tclSETGOALS = Comb.set
-
-  let tclEVARSADVANCE evd =
-    Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb })
-
-  let tclEVARUNIVCONTEXT ctx = 
-    Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx })
-
-  let reset_future_goals p =
-    { p with solution = Evd.reset_future_goals p.solution }
-
-  let mark_as_goal evd content =
-    let info = Evd.find evd content in
-    let info =
-      { info with Evd.evar_source = match info.Evd.evar_source with
-      | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
-      | loc,_ -> loc,Evar_kinds.GoalEvar }
-    in
-    let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with
-    | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () }
-    | Some () -> info
-    in
-    Evd.add evd content info
-
-  let advance = advance
-
-  let typeclass_resolvable = typeclass_resolvable
-
-end
-
-module UnsafeRepr = Proof.Unsafe
-
-let (>>=) = tclBIND
-let (<*>) = tclTHEN
-let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
-
-(** {6 Goal-dependent tactics} *)
-
-let goal_env evars gl =
-  let evi = Evd.find evars gl in
-  Evd.evar_filtered_env evi
-
-let goal_nf_evar sigma gl =
-  let evi = Evd.find sigma gl in
-  let evi = Evarutil.nf_evar_info sigma evi in
-  let sigma = Evd.add sigma gl evi in
-  (gl, sigma)
-
-let goal_extra evars gl =
-  let evi = Evd.find evars gl in
-  evi.Evd.evar_extra
-
-
-let catchable_exception = function
-  | Logic_monad.Exception _ -> false
-  | e -> Errors.noncritical e
-
-
-module Goal = struct
-
-  type ('a, 'r) t = {
-    env : Environ.env;
-    sigma : Evd.evar_map;
-    concl : Term.constr ;
-    self : Evar.t ; (* for compatibility with old-style definitions *)
-  }
-
-  type ('a, 'b) enter =
-    { enter : 'r. ('a, 'r) t -> 'b }
-
-  let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t)
-
-  let env { env=env } = env
-  let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma
-  let hyps { env=env } = Environ.named_context env
-  let concl { concl=concl } = concl
-  let extra { sigma=sigma; self=self } = goal_extra sigma self
-
-  let raw_concl { concl=concl } = concl
-
-
-  let gmake_with info env sigma goal = 
-    { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ;
-      sigma = sigma ;
-      concl = Evd.evar_concl info ;
-      self = goal }
-
-  let nf_gmake env sigma goal =
-    let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in
-    let sigma = Evd.add sigma goal info in
-    gmake_with info env sigma goal , sigma
-
-  let nf_enter f =
-    InfoL.tag (Info.Dispatch) begin
-    iter_goal begin fun goal ->
-      Env.get >>= fun env ->
-      tclEVARMAP >>= fun sigma ->
-      try
-        let (gl, sigma) = nf_gmake env sigma goal in
-        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl))
-      with e when catchable_exception e ->
-        let (e, info) = Errors.push e in
-        tclZERO ~info e
-    end
-    end
-
-  let normalize { self } =
-    Env.get >>= fun env ->
-    tclEVARMAP >>= fun sigma ->
-    let (gl,sigma) = nf_gmake env sigma self in
-    tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl)
-
-  let gmake env sigma goal =
-    let info = Evd.find sigma goal in
-    gmake_with info env sigma goal
-
-  let enter f =
-    let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in
-    InfoL.tag (Info.Dispatch) begin
-    iter_goal begin fun goal ->
-      Env.get >>= fun env ->
-      tclEVARMAP >>= fun sigma ->
-      try f (gmake env sigma goal)
-      with e when catchable_exception e ->
-        let (e, info) = Errors.push e in
-        tclZERO ~info e
-    end
-    end
-
-  type ('a, 'b) s_enter =
-    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
-
-  let s_enter f =
-    InfoL.tag (Info.Dispatch) begin
-    iter_goal begin fun goal ->
-      Env.get >>= fun env ->
-      tclEVARMAP >>= fun sigma ->
-      try
-        let gl = gmake env sigma goal in
-        let Sigma (tac, sigma, _) = f.s_enter gl in
-        let sigma = Sigma.to_evar_map sigma in
-        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
-      with e when catchable_exception e ->
-        let (e, info) = Errors.push e in
-        tclZERO ~info e
-    end
-    end
-
-  let nf_s_enter f =
-    InfoL.tag (Info.Dispatch) begin
-    iter_goal begin fun goal ->
-      Env.get >>= fun env ->
-      tclEVARMAP >>= fun sigma ->
-      try
-        let (gl, sigma) = nf_gmake env sigma goal in
-        let Sigma (tac, sigma, _) = f.s_enter gl in
-        let sigma = Sigma.to_evar_map sigma in
-        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
-      with e when catchable_exception e ->
-        let (e, info) = Errors.push e in
-        tclZERO ~info e
-    end
-    end
-
-  let goals =
-    Pv.get >>= fun step ->
-    let sigma = step.solution in
-    let map goal =
-      match advance sigma goal with
-      | None -> None (** ppedrot: Is this check really necessary? *)
-      | Some goal ->
-        let gl =
-          Env.get >>= fun env ->
-          tclEVARMAP >>= fun sigma ->
-          tclUNIT (gmake env sigma goal)
-        in
-        Some gl
-    in
-    tclUNIT (CList.map_filter map step.comb)
-
-  (* compatibility *)
-  let goal { self=self } = self
-
-  let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t)
-
-end
-
-
-
-(** {6 Trace} *)
-
-module Trace = struct
-
-  let record_info_trace = InfoL.record_trace
-
-  let log m = InfoL.leaf (Info.Msg m)
-  let name_tactic m t = InfoL.tag (Info.Tactic m) t
-
-  let pr_info ?(lvl=0) info =
-    assert (lvl >= 0);
-    Info.(print (collapse lvl info))
-
-end
-
-
-
-(** {6 Non-logical state} *)
-
-module NonLogical = Logic_monad.NonLogical
-
-let tclLIFT = Proof.lift
-
-let tclCHECKINTERRUPT =
-   tclLIFT (NonLogical.make Control.check_for_interrupt)
-
-
-
-
-
-(*** Compatibility layer with <= 8.2 tactics ***)
-module V82 = struct
-  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
-
-  let tactic tac =
-    (* spiwack: we ignore the dependencies between goals here,
-       expectingly preserving the semantics of <= 8.2 tactics *)
-    (* spiwack: convenience notations, waiting for ocaml 3.12 *)
-    let open Proof in
-    Pv.get >>= fun ps ->
-    try
-      let tac gl evd = 
-        let glsigma  =
-          tac { Evd.it = gl ; sigma = evd; }  in
-        let sigma = glsigma.Evd.sigma in
-        let g = glsigma.Evd.it in
-        ( g, sigma )
-      in
-        (* Old style tactics expect the goals normalized with respect to evars. *)
-      let (initgoals,initevd) =
-        Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution
-      in
-      let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in
-      let sgs = CList.flatten goalss in
-      let sgs = undefined evd sgs in
-      InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >>
-      Pv.set { ps with solution = evd; comb = sgs; }
-    with e when catchable_exception e ->
-      let (e, info) = Errors.push e in
-      tclZERO ~info e
-
-
-  (* normalises the evars in the goals, and stores the result in
-     solution. *)
-  let nf_evar_goals =
-    Pv.modify begin fun ps ->
-    let map g s = goal_nf_evar s g in
-    let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in
-    { ps with solution = evd; comb = goals; }
-    end
-      
-  let has_unresolved_evar pv =
-    Evd.has_undefined pv.solution
-
-  (* Main function in the implementation of Grab Existential Variables.*)
-  let grab pv =
-    let undef = Evd.undefined_map pv.solution in
-    let goals = CList.rev_map fst (Evar.Map.bindings undef) in
-    { pv with comb = goals }
-      
-    
-
-  (* Returns the open goals of the proofview together with the evar_map to 
-     interpret them. *)
-  let goals { comb = comb ; solution = solution; } =
-   { Evd.it = comb ; sigma = solution }
-
-  let top_goals initial { solution=solution; } =
-    let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in
-    { Evd.it = goals ; sigma=solution; }
-
-  let top_evars initial =
-    let evars_of_initial (c,_) =
-      Evar.Set.elements (Evd.evars_of_term c)
-    in
-    CList.flatten (CList.map evars_of_initial initial)
-
-  let of_tactic t gls =
-    try
-      let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in
-      let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in
-      { Evd.sigma = final.solution ; it = final.comb }
-    with Logic_monad.TacticFailure e as src ->
-      let (_, info) = Errors.push src in
-      iraise (e, info)
-
-  let put_status = Status.put
-
-  let catchable_exception = catchable_exception
-
-  let wrap_exceptions f =
-    try f ()
-    with e when catchable_exception e ->
-      let (e, info) = Errors.push e in tclZERO ~info e
-
-end
-
-(** {7 Notations} *)
-
-module Notations = struct
-  let (>>=) = tclBIND
-  let (<*>) = tclTHEN
-  let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
-  type ('a, 'b) enter = ('a, 'b) Goal.enter =
-    { enter : 'r. ('a, 'r) Goal.t -> 'b }
-  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
-    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
-end
diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli
deleted file mode 100644
index 7996b7969c..0000000000
--- a/pretyping/proofview.mli
+++ /dev/null
@@ -1,589 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This files defines the basic mechanism of proofs: the [proofview]
-    type is the state which tactics manipulate (a global state for
-    existential variables, together with the list of goals), and the type
-    ['a tactic] is the (abstract) type of tactics modifying the proof
-    state and returning a value of type ['a]. *)
-
-open Util
-open Term
-
-(** Main state of tactics *)
-type proofview
-
-(** Returns a stylised view of a proofview for use by, for instance,
-    ide-s. *)
-(* spiwack: the type of [proofview] will change as we push more
-   refined functions to ide-s. This would be better than spawning a
-   new nearly identical function everytime. Hence the generic name. *)
-(* In this version: returns the list of focused goals together with
-   the [evar_map] context. *)
-val proofview : proofview -> Goal.goal list * Evd.evar_map
-
-
-(** {6 Starting and querying a proof view} *)
-
-(** Abstract representation of the initial goals of a proof. *)
-type entry
-
-(** Optimize memory consumption *)
-val compact : entry -> proofview -> entry * proofview
-
-(** Initialises a proofview, the main argument is a list of
-    environments (including a [named_context] which are used as
-    hypotheses) pair with conclusion types, creating accordingly many
-    initial goals. Because a proof does not necessarily starts in an
-    empty [evar_map] (indeed a proof can be triggered by an incomplete
-    pretyping), [init] takes an additional argument to represent the
-    initial [evar_map]. *)
-val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview
-
-(** A [telescope] is a list of environment and conclusion like in
-    {!init}, except that each element may depend on the previous
-    goals. The telescope passes the goals in the form of a
-    [Term.constr] which represents the goal as an [evar]. The
-    [evar_map] is threaded in state passing style. *)
-type telescope =
-  | TNil of Evd.evar_map
-  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
-
-(** Like {!init}, but goals are allowed to be dependent on one
-    another. Dependencies between goals is represented with the type
-    [telescope] instead of [list]. Note that the first [evar_map] of
-    the telescope plays the role of the [evar_map] argument in
-    [init]. *)
-val dependent_init  : telescope -> entry * proofview
-
-(** [finished pv] is [true] if and only if [pv] is complete. That is,
-    if it has an empty list of focused goals. There could still be
-    unsolved subgoaled, but they would then be out of focus. *)
-val finished : proofview -> bool
-
-(** Returns the current [evar] state. *)
-val return : proofview -> Evd.evar_map
-
-val partial_proof : entry -> proofview -> constr list
-val initial_goals : entry -> (constr * types) list
-
-
-
-(** {6 Focusing commands} *)
-
-(** A [focus_context] represents the part of the proof view which has
-    been removed by a focusing action, it can be used to unfocus later
-    on. *)
-type focus_context
-
-(** Returns a stylised view of a focus_context for use by, for
-    instance, ide-s. *)
-(* spiwack: the type of [focus_context] will change as we push more
-   refined functions to ide-s. This would be better than spawning a
-   new nearly identical function everytime. Hence the generic name. *)
-(* In this version: the goals in the context, as a "zipper" (the first
-   list is in reversed order). *)
-val focus_context : focus_context -> Goal.goal list * Goal.goal list
-
-(** [focus i j] focuses a proofview on the goals from index [i] to
-    index [j] (inclusive, goals are indexed from [1]). I.e. goals
-    number [i] to [j] become the only focused goals of the returned
-    proofview.  It returns the focused proofview, and a context for
-    the focus stack. *)
-val focus : int -> int -> proofview -> proofview * focus_context
-
-(** Unfocuses a proofview with respect to a context. *)
-val unfocus : focus_context -> proofview -> proofview
-
-
-(** {6 The tactic monad} *)
-
-(** - Tactics are objects which apply a transformation to all the
-    subgoals of the current view at the same time. By opposition to
-    the old vision of applying it to a single goal. It allows tactics
-    such as [shelve_unifiable], tactics to reorder the focused goals,
-    or global automation tactic for dependent subgoals (instantiating
-    an evar has influences on the other goals of the proof in
-    progress, not being able to take that into account causes the
-    current eauto tactic to fail on some instances where it could
-    succeed).  Another benefit is that it is possible to write tactics
-    that can be executed even if there are no focused goals.
-    - Tactics form a monad ['a tactic], in a sense a tactic can be
-    seen as a function (without argument) which returns a value of
-    type 'a and modifies the environment (in our case: the view).
-    Tactics of course have arguments, but these are given at the
-    meta-level as OCaml functions.  Most tactics in the sense we are
-    used to return [()], that is no really interesting values. But
-    some might pass information around.  The tactics seen in Coq's
-    Ltac are (for now at least) only [unit tactic], the return values
-    are kept for the OCaml toolkit.  The operation or the monad are
-    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
-    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
-    (which is a specialized bind on unit-returning tactics).
-    - Tactics have support for full-backtracking. Tactics can be seen
-    having multiple success: if after returning the first success a
-    failure is encountered, the tactic can backtrack and use a second
-    success if available. The state is backtracked to its previous
-    value, except the non-logical state defined in the {!NonLogical}
-    module below.
-*)
-
-
-(** The abstract type of tactics *)
-type +'a tactic 
-
-(** Applies a tactic to the current proofview. Returns a tuple
-    [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv]
-    is the updated proofview, [b] a boolean which is [true] if the
-    tactic has not done any action considered unsafe (such as
-    admitting a lemma), [sh] is the list of goals which have been
-    shelved by the tactic, and [gu] the list of goals on which the
-    tactic has given up. In case of multiple success the first one is
-    selected. If there is no success, fails with
-    {!Logic_monad.TacticFailure}*)
-val apply : Environ.env -> 'a tactic -> proofview -> 'a
-                                                   * proofview
-                                                   * (bool*Goal.goal list*Goal.goal list)
-                                                   * Proofview_monad.Info.tree
-
-(** {7 Monadic primitives} *)
-
-(** Unit of the tactic monad. *)
-val tclUNIT : 'a -> 'a tactic
- 
-(** Bind operation of the tactic monad. *)
-val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
-
-(** Interprets the ";" (semicolon) of Ltac. As a monadic operation,
-    it's a specialized "bind". *)
-val tclTHEN : unit tactic -> 'a tactic -> 'a tactic
-
-(** [tclIGNORE t] has the same operational content as [t], but drops
-    the returned value. *)
-val tclIGNORE : 'a tactic -> unit tactic
-
-(** Generic monadic combinators for tactics. *)
-module Monad : Monad.S with type +'a t = 'a tactic
-
-(** {7 Failure and backtracking} *)
-
-(** [tclZERO e] fails with exception [e]. It has no success. *)
-val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic
-
-(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
-    the successes of [t1] have been depleted and it failed with [e],
-    then it behaves as [t2 e]. In other words, [tclOR] inserts a
-    backtracking point. *)
-val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
-
-(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
-    success or [t2 e] if [t1] fails with [e]. It is analogous to
-    [try/with] handler of exception in that it is not a backtracking
-    point. *)
-val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
-
-(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
-    succeeds at least once then it behaves as [tclBIND a s] otherwise,
-    if [a] fails with [e], then it behaves as [f e]. *)
-val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic
-
-(** [tclONCE t] behave like [t] except it has at most one success:
-    [tclONCE t] stops after the first success of [t]. If [t] fails
-    with [e], [tclONCE t] also fails with [e]. *)
-val tclONCE : 'a tactic -> 'a tactic
-
-(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
-    success. Otherwise it fails. The tactic [t] is run until its first
-    success, then a failure with exception [e] is simulated. It [t]
-    yields another success, then [tclEXACTLY_ONCE e t] fails with
-    [MoreThanOneSuccess] (it is a user error). Otherwise,
-    [tclEXACTLY_ONCE e t] succeeds with the first success of
-    [t]. Notice that the choice of [e] is relevant, as the presence of
-    further successes may depend on [e] (see {!tclOR}). *)
-exception MoreThanOneSuccess
-val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic
-
-(** [tclCASE t] splits [t] into its first success and a
-    continuation. It is the most general primitive to control
-    backtracking. *)
-type 'a case =
-  | Fail of iexn
-  | Next of 'a * (iexn -> 'a tactic)
-val tclCASE : 'a tactic -> 'a case tactic
-
-(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of
-    stopping after the first success, it succeeds like [t] until a
-    failure with an exception [e] such that [p e = Some e'] is raised. At
-    which point it drops the remaining successes, failing with [e'].
-    [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *)
-val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
-
-
-(** {7 Focusing tactics} *)
-
-(** [tclFOCUS i j t] applies [t] after focusing on the goals number
-    [i] to [j] (see {!focus}). The rest of the goals is restored after
-    the tactic action. If the specified range doesn't correspond to
-    existing goals, fails with [NoSuchGoals] (a user error). this
-    exception is caught at toplevel with a default message + a hook
-    message that can be customized by [set_nosuchgoals_hook] below.
-    This hook is used to add a suggestion about bullets when
-    applicable. *)
-exception NoSuchGoals of int
-val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit
-
-val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
-
-(** [tclFOCUSID x t] applies [t] on a (single) focused goal like
-    {!tclFOCUS}. The goal is found by its name rather than its
-    number.*)
-val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic
-
-(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the
-    specified range doesn't correspond to existing goals, behaves like
-    [tclUNIT ()] instead of failing. *)
-val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic
-
-
-(** {7 Dispatching on goals} *)
-
-(** Dispatch tacticals are used to apply a different tactic to each
-    goal under focus. They come in two flavours: [tclDISPATCH] takes a
-    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
-    takes a list of ['a tactic] and returns an ['a list tactic].
-
-    They both work by applying each of the tactic in a focus
-    restricted to the corresponding goal (starting with the first
-    goal). In the case of [tclDISPATCHL], the tactic returns a list of
-    the same size as the argument list (of tactics), each element
-    being the result of the tactic executed in the corresponding goal.
-
-    When the length of the tactic list is not the number of goal,
-    raises [SizeMismatch (g,t)] where [g] is the number of available
-    goals, and [t] the number of tactics passed. *)
-exception SizeMismatch of int*int
-val tclDISPATCH : unit tactic list -> unit tactic
-val tclDISPATCHL : 'a tactic list -> 'a list tactic
-
-(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
-    tactic is "repeated" enough time such that every goal has a tactic
-    assigned to it ([b] is the list of tactics applied to the first
-    goals, [e] to the last goals, and [r] is applied to every goal in
-    between). *)
-val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic
-
-(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from
-    the first one to the last one. Backtracking in one goal is
-    independent of backtracking in another. It is equivalent to
-    [tclEXTEND [] tac []]. *)
-val tclINDEPENDENT : unit tactic -> unit tactic
-
-
-(** {7 Goal manipulation} *)
-
-(** Shelves all the goals under focus. The goals are placed on the
-    shelf for later use (or being solved by side-effects). *)
-val shelve : unit tactic
-
-(** Shelves the unifiable goals under focus, i.e. the goals which
-    appear in other goals under focus (the unfocused goals are not
-    considered). *)
-val shelve_unifiable : unit tactic
-
-(** [guard_no_unifiable] returns the list of unifiable goals if some
-    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
-val guard_no_unifiable : Names.Name.t list option tactic
-
-(** [unshelve l p] adds all the goals in [l] at the end of the focused
-    goals of p *)
-val unshelve : Goal.goal list -> proofview -> proofview
-
-(** [with_shelf tac] executes [tac] and returns its result together with the set
-    of goals shelved by [tac]. The current shelf is unchanged. *)
-val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic
-
-(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
-    is negative, then it puts the [n] last goals first.*)
-val cycle : int -> unit tactic
-
-(** [swap i j] swaps the position of goals number [i] and [j]
-    (negative numbers can be used to address goals from the end. Goals
-    are indexed from [1]. For simplicity index [0] corresponds to goal
-    [1] as well, rather than raising an error. *)
-val swap : int -> int -> unit tactic
-
-(** [revgoals] reverses the list of focused goals. *)
-val revgoals : unit tactic
-
-(** [numgoals] returns the number of goals under focus. *)
-val numgoals : int tactic
-
-
-(** {7 Access primitives} *)
-
-(** [tclEVARMAP] doesn't affect the proof, it returns the current
-    [evar_map]. *)
-val tclEVARMAP : Evd.evar_map tactic
-
-(** [tclENV] doesn't affect the proof, it returns the current
-    environment. It is not the environment of a particular goal,
-    rather the "global" environment of the proof. The goal-wise
-    environment is obtained via {!Proofview.Goal.env}. *)
-val tclENV : Environ.env tactic
-
-
-(** {7 Put-like primitives} *)
-
-(** [tclEFFECTS eff] add the effects [eff] to the current state. *)
-val tclEFFECTS : Safe_typing.private_constants -> unit tactic
-
-(** [mark_as_unsafe] declares the current tactic is unsafe. *)
-val mark_as_unsafe : unit tactic
-
-(** Gives up on the goal under focus. Reports an unsafe status. Proofs
-    with given up goals cannot be closed. *)
-val give_up : unit tactic
-
-
-(** {7 Control primitives} *)
-
-(** [tclPROGRESS t] checks the state of the proof after [t]. It it is
-    identical to the state before, then [tclePROGRESS t] fails, otherwise
-    it succeeds like [t]. *)
-val tclPROGRESS : 'a tactic -> 'a tactic
-
-(** Checks for interrupts *)
-val tclCHECKINTERRUPT : unit tactic
-
-exception Timeout
-(** [tclTIMEOUT n t] can have only one success.
-    In case of timeout if fails with [tclZERO Timeout]. *)
-val tclTIMEOUT : int -> 'a tactic -> 'a tactic
-
-(** [tclTIME s t] displays time for each atomic call to t, using s as an
-    identifying annotation if present *)
-val tclTIME : string option -> 'a tactic -> 'a tactic
-
-(** {7 Unsafe primitives} *)
-
-(** The primitives in the [Unsafe] module should be avoided as much as
-    possible, since they can make the proof state inconsistent. They are
-    nevertheless helpful, in particular when interfacing the pretyping and
-    the proof engine. *)
-module Unsafe : sig
-
-  (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If
-      [sigma] has new unresolved [evar]-s they will not appear as
-      goal. If goals have been solved in [sigma] they will still
-      appear as unsolved goals. *)
-  val tclEVARS : Evd.evar_map -> unit tactic
-    
-  (** Like {!tclEVARS} but also checks whether goals have been solved. *)
-  val tclEVARSADVANCE : Evd.evar_map -> unit tactic
-
-  (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently
-      being proved, appending them to the list of focused goals. If a
-      goal is already solved, it is not added. *)
-  val tclNEWGOALS : Goal.goal list -> unit tactic
-
-  (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a
-      goal is already solved, it is not set. *)
-  val tclSETGOALS : Goal.goal list -> unit tactic
-
-  (** [tclGETGOALS] returns the list of goals under focus. *)
-  val tclGETGOALS : Goal.goal list tactic
-
-  (** Sets the evar universe context. *)
-  val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic
-
-  (** Clears the future goals store in the proof view. *)
-  val reset_future_goals : proofview -> proofview
-
-  (** Give an evar the status of a goal (changes its source location
-      and makes it unresolvable for type classes. *)
-  val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map
-
-  (** [advance sigma g] returns [Some g'] if [g'] is undefined and is
-      the current avatar of [g] (for instance [g] was changed by [clear]
-      into [g']). It returns [None] if [g] has been (partially)
-      solved. *)
-  val advance : Evd.evar_map -> Evar.t -> Evar.t option
-
-  val typeclass_resolvable : unit Evd.Store.field
-
-end
-
-(** This module gives access to the innards of the monad. Its use is
-    restricted to very specific cases. *)
-module UnsafeRepr :
-sig
-  type state = Proofview_monad.Logical.Unsafe.state
-  val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t
-  val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic
-end
-
-(** {6 Goal-dependent tactics} *)
-
-module Goal : sig
-
-  (** Type of goals.
-
-      The first parameter type is a phantom argument indicating whether the data
-      contained in the goal has been normalized w.r.t. the current sigma. If it
-      is the case, it is flagged [ `NF ]. You may still access the un-normalized
-      data using {!assume} if you known you do not rely on the assumption of
-      being normalized, at your own risk.
-
-      The second parameter is a stage indicating where the goal belongs. See
-      module {!Sigma}.
-  *)
-  type ('a, 'r) t
-
-  (** Assume that you do not need the goal to be normalized. *)
-  val assume : ('a, 'r) t -> ([ `NF ], 'r) t
-
-  (** Normalises the argument goal. *)
-  val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic
-
-  (** [concl], [hyps], [env] and [sigma] given a goal [gl] return
-      respectively the conclusion of [gl], the hypotheses of [gl], the
-      environment of [gl] (i.e. the global environment and the
-      hypotheses) and the current evar map. *)
-  val concl : ([ `NF ], 'r) t -> Term.constr
-  val hyps : ([ `NF ], 'r) t -> Context.Named.t
-  val env : ('a, 'r) t -> Environ.env
-  val sigma : ('a, 'r) t -> 'r Sigma.t
-  val extra : ('a, 'r) t -> Evd.Store.t
-
-  (** Returns the goal's conclusion even if the goal is not
-      normalised. *)
-  val raw_concl : ('a, 'r) t -> Term.constr
-
-  type ('a, 'b) enter =
-    { enter : 'r. ('a, 'r) t -> 'b }
-
-  (** [nf_enter t] applies the goal-dependent tactic [t] in each goal
-      independently, in the manner of {!tclINDEPENDENT} except that
-      the current goal is also given as an argument to [t]. The goal
-      is normalised with respect to evars. *)
-  val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic
-
-  (** Like {!nf_enter}, but does not normalize the goal beforehand. *)
-  val enter : ([ `LZ ], unit tactic) enter -> unit tactic
-
-  type ('a, 'b) s_enter =
-    { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
-
-  (** A variant of {!enter} allows to work with a monotonic state. The evarmap
-      returned by the argument is put back into the current state before firing
-      the returned tactic. *)
-  val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic
-
-  (** Like {!s_enter}, but normalizes the goal beforehand. *)
-  val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic
-
-  (** Recover the list of current goals under focus, without evar-normalization.
-      FIXME: encapsulate the level in an existential type. *)
-  val goals : ([ `LZ ], 'r) t tactic list tactic
-
-  (** Compatibility: avoid if possible *)
-  val goal : ([ `NF ], 'r) t -> Evar.t
-
-  (** Every goal is valid at a later stage. FIXME: take a later evarmap *)
-  val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t
-
-end
-
-
-(** {6 Trace} *)
-
-module Trace : sig
-
-  (** [record_info_trace t] behaves like [t] except the [info] trace
-      is stored. *)
-  val record_info_trace : 'a tactic -> 'a tactic
-
-  val log : Proofview_monad.lazy_msg -> unit tactic
-  val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic
-
-  val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds
-
-end
-
-
-(** {6 Non-logical state} *)
-
-(** The [NonLogical] module allows the execution of effects (including
-    I/O) in tactics (non-logical side-effects are not discarded at
-    failures). *)
-module NonLogical : module type of Logic_monad.NonLogical
-
-(** [tclLIFT c] is a tactic which behaves exactly as [c]. *)
-val tclLIFT : 'a NonLogical.t -> 'a tactic
-
-
-(**/**)
-
-(*** Compatibility layer with <= 8.2 tactics ***)
-module V82 : sig
-  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
-  val tactic : tac -> unit tactic
-
-  (* normalises the evars in the goals, and stores the result in
-     solution. *)
-  val nf_evar_goals : unit tactic
-
-  val has_unresolved_evar : proofview -> bool
-
-  (* Main function in the implementation of Grab Existential Variables.
-     Resets the proofview's goals so that it contains all unresolved evars
-     (in chronological order of insertion). *)
-  val grab : proofview -> proofview
-
-  (* Returns the open goals of the proofview together with the evar_map to 
-     interpret them. *)
-  val goals : proofview -> Evar.t list Evd.sigma
-
-  val top_goals : entry -> proofview -> Evar.t list Evd.sigma
-  
-  (* returns the existential variable used to start the proof *)
-  val top_evars : entry -> Evd.evar list
-
-  (* Caution: this function loses quite a bit of information. It
-     should be avoided as much as possible.  It should work as
-     expected for a tactic obtained from {!V82.tactic} though. *)
-  val of_tactic : 'a tactic -> tac
-
-  (* marks as unsafe if the argument is [false] *)
-  val put_status : bool -> unit tactic
-
-  (* exception for which it is deemed to be safe to transmute into
-     tactic failure. *)
-  val catchable_exception : exn -> bool
-
-  (* transforms every Ocaml (catchable) exception into a failure in
-     the monad. *)
-  val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
-end
-
-(** {7 Notations} *)
-
-module Notations : sig
-
-  (** {!tclBIND} *)
-  val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
-  (** {!tclTHEN} *)
-  val (<*>) : unit tactic -> 'a tactic -> 'a tactic
-  (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
-  val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
-
-  type ('a, 'b) enter = ('a, 'b) Goal.enter =
-    { enter : 'r. ('a, 'r) Goal.t -> 'b }
-  type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
-    { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
-end
-- 
cgit v1.2.3


From 25c6356326773ac56380b81de6f58d15caae8680 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 25 Mar 2016 01:42:38 +0100
Subject: Fix a bug in Program coercion code

It was not accounting for the universe constraints generated by
applications of the coercion.
---
 pretyping/coercion.ml | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311bc6..d00445958f 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -129,7 +129,7 @@ let mu env evdref t =
   let rec aux v =
     let v' = hnf env !evdref v in
       match disc_subset v' with
-      Some (u, p) ->
+      | Some (u, p) ->
 	let f, ct = aux u in
 	let p = hnf_nodelta env !evdref p in
 	  (Some (fun x ->
@@ -241,7 +241,6 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		     let remove_head a c =
 		       match kind_of_term c with
 		       | Lambda (n, t, t') -> c, t'
-			   (*| Prod (n, t, t') -> t'*)
 		       | Evar (k, args) ->
 			   let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in
 			     evdref := evs;
@@ -297,9 +296,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		      with NoSubtacCoercion ->
 			let typ = Typing.unsafe_type_of env evm c in
 			let typ' = Typing.unsafe_type_of env evm c' in
-			  (* 			     if not (is_arity env evm typ) then *)
 			  coerce_application typ typ' c c' l l')
-		       (* 			     else subco () *)
 		 else
 		   subco ()
 	   | x, y when Constr.equal c c' ->
@@ -307,9 +304,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 		 let evm =  !evdref in
 		 let lam_type = Typing.unsafe_type_of env evm c in
 		 let lam_type' = Typing.unsafe_type_of env evm c' in
-		   (* 			 if not (is_arity env evm lam_type) then ( *)
 		   coerce_application lam_type lam_type' c c' l l'
-		     (* 			 ) else subco () *)
 	       else subco ()
 	   | _ -> subco ())
       | _, _ ->  subco ()
@@ -335,10 +330,17 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
 	    raise NoSubtacCoercion
   in coerce_unify env x y
 
+let app_coercion env evdref coercion v =
+  match coercion with
+  | None -> v
+  | Some f ->
+     let v' = Typing.solve_evars env evdref (f v) in
+     whd_betaiota !evdref v'
+
 let coerce_itf loc env evd v t c1 =
   let evdref = ref evd in
   let coercion = coerce loc env evdref t c1 in
-  let t = Option.map (app_opt env evdref coercion) v in
+  let t = Option.map (app_coercion env evdref coercion) v in
     !evdref, t
 
 let saturate_evd env evd =
@@ -424,7 +426,7 @@ let inh_coerce_to_base loc env evd j =
     let evdref = ref evd in
     let ct, typ' = mu env evdref j.uj_type in
     let res =
-      { uj_val = app_opt env evdref ct j.uj_val;
+      { uj_val = app_coercion env evdref ct j.uj_val;
 	uj_type = typ' }
     in !evdref, res
   else (evd, j)
-- 
cgit v1.2.3


From c4d62e3686926c27b172636ca8b746814d13a462 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 20 Mar 2016 23:34:07 +0100
Subject: Moving type_uconstr to Pretyping.

---
 pretyping/pretyping.ml  | 25 +++++++++++++++++++++++++
 pretyping/pretyping.mli |  8 ++++++++
 2 files changed, 33 insertions(+)

(limited to 'pretyping')

diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index a765d30913..8baa668c7b 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -58,6 +58,8 @@ type ltac_var_map = {
 }
 type glob_constr_ltac_closure = ltac_var_map * glob_constr
 type pure_open_constr = evar_map * constr
+type 'a delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
 
 (************************************************************************)
 (* This concerns Cases *)
@@ -1107,3 +1109,26 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W
 
 let understand_ltac flags env sigma lvar kind c =
   ise_pretype_gen flags env sigma lvar kind c
+
+let constr_flags = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = None;
+  fail_evar = true;
+  expand_evars = true }
+
+(* Fully evaluate an untyped constr *)
+let type_uconstr ?(flags = constr_flags)
+  ?(expected_type = WithoutTypeConstraint) ist c =
+  { delayed = begin fun env sigma ->
+  let { closure; term } = c in
+  let vars = {
+    ltac_constrs = closure.typed;
+    ltac_uconstrs = closure.untyped;
+    ltac_idents = closure.idents;
+    ltac_genargs = ist.Geninterp.lfun;
+  } in
+  let sigma = Sigma.to_evar_map sigma in
+  let (sigma, c) = understand_ltac flags env sigma vars expected_type term in
+  Sigma.Unsafe.of_pair (c, sigma)
+  end }
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 4c4c535d8c..91320f20a5 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -55,6 +55,9 @@ type inference_flags = {
   expand_evars : bool
 }
 
+type 'a delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
 val default_inference_flags : bool -> inference_flags
 
 val no_classes_no_fail_inference_flags : inference_flags
@@ -114,6 +117,11 @@ val understand_judgment : env -> evar_map ->
 val understand_judgment_tcc : env -> evar_map ref ->
   glob_constr -> unsafe_judgment
 
+val type_uconstr :
+  ?flags:inference_flags ->
+  ?expected_type:typing_constraint ->
+  Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open
+
 (** Trying to solve remaining evars and remaining conversion problems
     possibly using type classes, heuristics, external tactic solver
     hook depending on given flags. *)
-- 
cgit v1.2.3