Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

44 files changed, 4762 insertions, 2660 deletions

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 1f7bdad3..1d7da3f3 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml 10071 2007-08-10 15:34:41Z herbelin $ *)
+(* $Id: cases.ml 11085 2008-06-10 08:54:43Z herbelin $ *)
 
 open Util
 open Names
@@ -20,12 +20,12 @@ open Sign
 open Reductionops
 open Typeops
 open Type_errors
-
 open Rawterm
 open Retyping
 open Pretype_errors
 open Evarutil
 open Evarconv
+open Evd
 
 (* Pattern-matching errors *)
 
@@ -63,16 +63,48 @@ let error_wrong_predicate_arity_loc loc env c n1 n2 =
 let error_needs_inversion env x t =
   raise (PatternMatchingError (env, NeedsInversion (x,t)))
 
+(**********************************************************************)
+(* Functions to deal with impossible cases *)
+
+let impossible_default_case = ref None
+
+let set_impossible_default_clause c = impossible_default_case := Some c
+
+let coq_unit_judge =
+  let na1 = Name (id_of_string "A") in
+  let na2 = Name (id_of_string "H") in
+  fun () -> 
+    match !impossible_default_case with
+    | Some (id,type_of_id) ->
+	make_judge id type_of_id
+    | None -> 
+	(* In case the constants id/ID are not defined *)
+	make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1)))
+                 (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2)))
+
+(**********************************************************************)
+
 module type S = sig
   val compile_cases :
-    loc ->
-    (type_constraint -> env -> rawconstr -> unsafe_judgment) *
-      Evd.evar_defs ref ->
+    loc -> case_style ->
+    (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref ->
     type_constraint -> 
-    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    env -> rawconstr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
 
+let rec list_try_compile f = function
+  | [a] -> f a
+  | [] -> anomaly "try_find_f"
+  | h::t ->
+      try f h 
+      with UserError _ | TypeError _ | PretypeError _ 
+	| Stdpp.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) ->
+	    list_try_compile f t
+
+let force_name =
+  let nx = Name (id_of_string "x") in function Anonymous -> nx | na -> na
+
 (************************************************************************)
 (*            Pattern-matching compilation (Cases)                      *)
 (************************************************************************)
@@ -86,8 +118,8 @@ let mssg_may_need_inversion () =
   str "Found a matching with no clauses on a term unknown to have an empty inductive type"
 
 (* Utils *)
-let make_anonymous_patvars =
-  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
+let make_anonymous_patvars n =
+  list_make n (PatVar (dummy_loc,Anonymous)) 
 
 (* Environment management *)
 let push_rels vars env = List.fold_right push_rel vars env
@@ -112,77 +144,53 @@ type alias_constr =
 
 let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
   { uj_val =
-      (match d with
-	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
-	| NonDepAlias ->
-	    if (not (dependent (mkRel 1) j.uj_type))
-	      or (* A leaf: *) isRel deppat
-	    then 
-	      (* The body of pat is not needed to type j - see *)
-	      (* insert_aliases - and both deppat and nondeppat have the *)
-	      (* same type, then one can freely substitute one by the other *)
-	      subst1 nondeppat j.uj_val
-	    else
-	      (* The body of pat is not needed to type j but its value *)
-	      (* is dependent in the type of j; our choice is to *)
-	      (* enforce this dependency *)
-	      mkLetIn (na,deppat,t,j.uj_val));
+    if
+      isRel deppat or not (dependent (mkRel 1) j.uj_val) or
+      d = NonDepAlias & not (dependent (mkRel 1) j.uj_type)
+    then
+      (* The body of pat is not needed to type j - see *)
+      (* insert_aliases - and both deppat and nondeppat have the *)
+      (* same type, then one can freely substitute one by the other *)
+      subst1 nondeppat j.uj_val
+    else
+      (* The body of pat is not needed to type j but its value *)
+      (* is dependent in the type of j; our choice is to *)
+      (* enforce this dependency *)
+      mkLetIn (na,deppat,t,j.uj_val);
     uj_type = subst1 deppat j.uj_type }
 
 (**********************************************************************)
 (* Structures used in compiling pattern-matching *)
-type 'a lifted = int * 'a
-
-let insert_lifted a = (0,a);;
 
-type rhs =
+type 'a rhs =
     { rhs_env    : env;
+      rhs_vars   : identifier list;
       avoid_ids  : identifier list;
-      rhs_lift   : int;
-      it         : rawconstr }
+      it         : 'a option}
 
-type equation =
-    { dependencies : constr lifted list;
-      patterns     : cases_pattern list; 
-      rhs          : rhs;
+type 'a equation =
+    { patterns     : cases_pattern list; 
+      rhs          : 'a rhs;
       alias_stack  : name list;
       eqn_loc      : loc;
-      used         : bool ref;
-      tag          : pattern_source }
+      used         : bool ref }
+
+type 'a matrix = 'a equation list
 
-type matrix = equation list
+type dep_status = KnownDep | KnownNotDep | DepUnknown
 
 (* 1st argument of IsInd is the original ind before extracting the summary *)
 type tomatch_type =
-  | IsInd of types * inductive_type
+  | IsInd of types * inductive_type * name list
   | NotInd of constr option * types
 
 type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list)
+  | Pushed of ((constr * tomatch_type) * int list * (name * dep_status))
   | Alias of (constr * constr * alias_constr * constr)
   | Abstract of rel_declaration
 
 type tomatch_stack = tomatch_status list
 
-(* The type [predicate_signature] types the terms to match and the rhs:
-
-   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
-     if dep<>Anonymous, the term is dependent, let n=|names|, if
-     n<>0 then the type of the pushed term is necessarily an
-     inductive with n real arguments. Otherwise, it may be
-     non inductive, or inductive without real arguments, or inductive
-     originating from a subterm in which case real args are not dependent;
-     it accounts for n+1 binders if dep or n binders if not dep
-   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
-   - [PrCcl] types the right-hand-side
-   - Aliases [Alias] have no trace in [predicate_signature]
-*)
-
-type predicate_signature =
-  | PrLetIn of (name list * name) * predicate_signature
-  | PrProd of predicate_signature
-  | PrCcl of constr
-
 (* We keep a constr for aliases and a cases_pattern for error message *)
 
 type alias_builder =
@@ -251,7 +259,7 @@ let push_history_pattern n current cont =
 
 (* A pattern-matching problem has the following form:
 
-   env, isevars |- <pred> Cases tomatch of mat end
+   env, evd |- <pred> Cases tomatch of mat end
 
   where tomatch is some sequence of "instructions" (t1  ... tn)
 
@@ -281,15 +289,17 @@ let push_history_pattern n current cont =
   of variables).
 
 *)
-type pattern_matching_problem =
-    { env      : env;
-      isevars  : Evd.evar_defs ref;
-      pred     : predicate_signature option;
-      tomatch  : tomatch_stack;
-      history  : pattern_continuation;
-      mat      : matrix;
-      caseloc  : loc;
-      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+
+type 'a pattern_matching_problem =
+    { env       : env;
+      evdref    : evar_defs ref;
+      pred      : constr;
+      tomatch   : tomatch_stack;
+      history   : pattern_continuation;
+      mat       : 'a matrix;
+      caseloc   : loc;
+      casestyle : case_style;
+      typing_function: type_constraint -> env -> evar_defs ref -> 'a option -> unsafe_judgment }
 
 (*--------------------------------------------------------------------------*
  * A few functions to infer the inductive type from the patterns instead of *
@@ -312,123 +322,129 @@ let rec find_row_ind = function
   | PatVar _ :: l -> find_row_ind l
   | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
 
-let inductive_template isevars env tmloc ind =
+let inductive_template evdref env tmloc ind =
   let arsign = get_full_arity_sign env ind in
   let hole_source = match tmloc with 
-    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
-    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
+    | Some loc -> fun i -> (loc, TomatchTypeParameter (ind,i))
+    | None -> fun _ -> (dummy_loc, InternalHole) in
    let (_,evarl,_) =
     List.fold_right
       (fun (na,b,ty) (subst,evarl,n) ->
 	match b with
         | None ->
 	    let ty' = substl subst ty in
-	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
+	    let e = e_new_evar evdref env ~src:(hole_source n) ty' in
 	    (e::subst,e::evarl,n+1) 
 	| Some b ->
 	    (b::subst,evarl,n+1))
       arsign ([],[],1) in
    applist (mkInd ind,List.rev evarl)
 
-let inh_coerce_to_ind isevars env ty tyi =
-  let expected_typ = inductive_template isevars env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour 
-        un inductif cela doit être égal *)
-  let _ = e_cumul env isevars expected_typ ty in ()
+let try_find_ind env sigma typ realnames =
+  let (IndType(_,realargs) as ind) = find_rectype env sigma typ in
+  let names =
+    match realnames with
+      | Some names -> names
+      | None -> list_make (List.length realargs) Anonymous in
+  IsInd (typ,ind,names)
 
-let unify_tomatch_with_patterns isevars env loc typ pats =
+
+let inh_coerce_to_ind evdref env ty tyi =
+  let expected_typ = inductive_template evdref env None tyi in
+     (* devrait être indifférent d'exiger leq ou pas puisque pour 
+        un inductif cela doit être égal *)
+  let _ = e_cumul env evdref expected_typ ty in ()
+
+let unify_tomatch_with_patterns evdref env loc typ pats realnames =
   match find_row_ind pats with
     | None -> NotInd (None,typ)
     | Some (_,(ind,_)) ->
-	inh_coerce_to_ind isevars env typ ind;
-	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+	inh_coerce_to_ind evdref env typ ind;
+	try try_find_ind env (evars_of !evdref) typ realnames
 	with Not_found -> NotInd (None,typ)
 
-let find_tomatch_tycon isevars env loc = function
+let find_tomatch_tycon evdref env loc = function
   (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
-  | None -> empty_tycon
+  | Some (_,ind,_,realnal) -> 		  
+      mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal)
+  | None -> 
+      empty_tycon,None
 
-let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
+let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
   let loc = Some (loc_of_rawconstr tomatch) in
-  let tycon = find_tomatch_tycon isevars env loc indopt in
-  let j = typing_fun tycon env tomatch in
-  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+  let tycon,realnames = find_tomatch_tycon evdref env loc indopt in
+  let j = typing_fun tycon env evdref tomatch in
+  let typ = nf_evar (evars_of !evdref) j.uj_type in
   let t =
-    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+    try try_find_ind env (evars_of !evdref) typ realnames
     with Not_found ->
-      unify_tomatch_with_patterns isevars env loc typ pats in
+      unify_tomatch_with_patterns evdref env loc typ pats realnames in
   (j.uj_val,t)
 
-let coerce_to_indtype typing_fun isevars env matx tomatchl =
+let coerce_to_indtype typing_fun evdref env matx tomatchl =
   let pats = List.map (fun r ->  r.patterns) matx in
   let matx' = match matrix_transpose pats with
     | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
     | m -> m in
-  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+  List.map2 (coerce_row typing_fun evdref env) matx' tomatchl
 
 (************************************************************************)
 (* Utils *)
 
-let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
-  e_new_evar isevars env ~src:src (new_Type ())
+let mkExistential env ?(src=(dummy_loc,InternalHole)) evdref =
+  e_new_evar evdref env ~src:src (new_Type ())
 
-let evd_comb2 f isevars x y =
-  let (evd',y) = f !isevars x y in
-  isevars := evd';
+let evd_comb2 f evdref x y =
+  let (evd',y) = f !evdref x y in
+  evdref := evd';
   y
 
 
 module Cases_F(Coercion : Coercion.S) : S = struct
 
-let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
   (* Ideally, we could find a common inductive type to which both the
      term to match and the patterns coerce *)
   (* In practice, we coerce the term to match if it is not already an
      inductive type and it is not dependent; moreover, we use only 
      the first pattern type and forget about the others *)
-  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+  let typ,names =
+    match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in
   let typ =
-    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+    try try_find_ind pb.env (evars_of !(pb.evdref)) typ names
     with Not_found -> NotInd (None,typ) in
-  let tomatch = ((current,typ),deps) in
+  let tomatch = ((current,typ),deps,dep) in
   match typ with
   | NotInd (None,typ) ->
       let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
       (match find_row_ind tm1 with
 	| None -> tomatch
 	| Some (_,(ind,_)) ->
-	    let indt = inductive_template pb.isevars pb.env None ind in
+	    let indt = inductive_template pb.evdref pb.env None ind in
 	    let current =
 	      if deps = [] & isEvar typ then
 	      (* Don't insert coercions if dependent; only solve evars *)
-		let _ = e_cumul pb.env pb.isevars indt typ in
+		let _ = e_cumul pb.env pb.evdref indt typ in
 		current
 	      else
 		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
-		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma = Evd.evars_of !(pb.isevars) in
-	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
-	    ((current,typ),deps))
+		  pb.evdref (make_judge current typ) (mk_tycon_type indt)).uj_val in
+	    let sigma = evars_of !(pb.evdref) in
+	    let typ = try_find_ind pb.env sigma indt names in
+	    ((current,typ),deps,dep))
   | _ -> tomatch
 
-   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
-let to_mutind env isevars tm c t =
-(*  match c with
-    | Some body -> *) NotInd (c,t)
-(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
-
 let type_of_tomatch = function
-  | IsInd (t,_) -> t
+  | IsInd (t,_,_) -> t
   | NotInd (_,t) -> t
 
 let mkDeclTomatch na = function
-  | IsInd (t,_) -> (na,None,t)
+  | IsInd (t,_,_) -> (na,None,t)
   | NotInd (c,t) -> (na,c,t)
 
 let map_tomatch_type f = function
-  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
-  | NotInd (c,t) -> NotInd (option_map f c, f t)
+  | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names)
+  | NotInd (c,t) -> NotInd (Option.map f c, f t)
 
 let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
 let lift_tomatch_type n = liftn_tomatch_type n 1
@@ -465,25 +481,6 @@ let remove_current_pattern eqn =
 let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
 
 (**********************************************************************)
-(* Dealing with regular and default patterns *)
-let is_regular eqn = eqn.tag = RegularPat
-
-let lower_pattern_status = function
-  | RegularPat -> DefaultPat 0
-  | DefaultPat n -> DefaultPat (n+1)
-
-let pattern_status pats =
-  if array_exists ((=) RegularPat) pats then RegularPat
-  else 
-    let min =
-      Array.fold_right
-	(fun pat n -> match pat with
-	   | DefaultPat i when i<n -> i
-	   | _ -> n)
-	pats 0 in
-    DefaultPat min
-
-(**********************************************************************)
 (* Well-formedness tests *)
 (* Partial check on patterns *)
 
@@ -541,7 +538,7 @@ let extract_rhs pb =
     | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
     | eqn::_ ->
 	set_used_pattern eqn;
-	eqn.tag, eqn.rhs
+        eqn.rhs
 
 (**********************************************************************)
 (* Functions to deal with matrix factorization *)
@@ -549,23 +546,35 @@ let extract_rhs pb =
 let occur_in_rhs na rhs =
   match na with
     | Anonymous -> false
-    | Name id -> occur_rawconstr id rhs.it
+    | Name id -> List.mem id rhs.rhs_vars
 
-let is_dep_patt eqn = function
+let is_dep_patt_in eqn = function
   | PatVar (_,name) -> occur_in_rhs name eqn.rhs
   | PatCstr _ -> true
 
-let dependencies_in_rhs nargs eqns =
-  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
-  else
-  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
-  let columns = matrix_transpose deps in
-  List.map (List.exists ((=) true)) columns
+let mk_dep_patt_row (pats,eqn) =
+  List.map (is_dep_patt_in eqn) pats
+
+let dependencies_in_pure_rhs nargs eqns =
+  if eqns = [] then list_make nargs false (* Only "_" patts *) else
+  let deps_rows = List.map mk_dep_patt_row eqns in
+  let deps_columns = matrix_transpose deps_rows in
+  List.map (List.exists ((=) true)) deps_columns
 
 let dependent_decl a = function
   | (na,None,t) -> dependent a t
   | (na,Some c,t) -> dependent a t || dependent a c
 
+let rec dep_in_tomatch n = function
+  | (Pushed _ | Alias _) :: l -> dep_in_tomatch n l
+  | Abstract d :: l -> dependent_decl (mkRel n) d or dep_in_tomatch (n+1) l
+  | [] -> false
+
+let dependencies_in_rhs nargs current tms eqns =
+  match kind_of_term current with
+  | Rel n when dep_in_tomatch n tms -> list_make nargs true
+  | _ -> dependencies_in_pure_rhs nargs eqns
+
 (* Computing the matrix of dependencies *)
 
 (* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
@@ -609,36 +618,41 @@ let find_dependencies_signature deps_in_rhs typs =
 
 let regeneralize_index_tomatch n =
   let rec genrec depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
+  | [] -> 
+      []
+  | Pushed ((c,tm),l,dep) :: rest ->
       let c = regeneralize_index n depth c in
       let tm = map_tomatch_type (regeneralize_index n depth) tm in
       let l = List.map (regeneralize_rel n depth) l in
-      Pushed ((c,tm),l)::(genrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
-  | Abstract d::rest ->
+      Pushed ((c,tm),l,dep) :: genrec depth rest
+  | Alias (c1,c2,d,t) :: rest ->
+      Alias (regeneralize_index n depth c1,c2,d,t) :: genrec depth rest
+  | Abstract d :: rest ->
       Abstract (map_rel_declaration (regeneralize_index n depth) d)
-      ::(genrec (depth+1) rest) in
+      :: genrec (depth+1) rest in
   genrec 0
 
 let rec replace_term n c k t = 
   if t = mkRel (n+k) then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
+let length_of_tomatch_type_sign (dep,_) = function
+  | NotInd _ -> if dep<>Anonymous then 1 else 0
+  | IsInd (_,_,names) -> List.length names + if dep<>Anonymous then 1 else 0
+
 let replace_tomatch n c =
   let rec replrec depth = function
   | [] -> []
-  | Pushed ((b,tm),l)::rest ->
+  | Pushed ((b,tm),l,dep) :: rest ->
       let b = replace_term n c depth b in
       let tm = map_tomatch_type (replace_term n c depth) tm in
       List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l)::(replrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
-  | Abstract d::rest ->
+      Pushed ((b,tm),l,dep) :: replrec depth rest
+  | Alias (c1,c2,d,t) :: rest ->
+      Alias (replace_term n c depth c1,c2,d,t) :: replrec depth rest
+  | Abstract d :: rest ->
       Abstract (map_rel_declaration (replace_term n c depth) d)
-      ::(replrec (depth+1) rest) in
+      :: replrec (depth+1) rest in
   replrec 0
 
 let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
@@ -646,11 +660,11 @@ let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
 
 let rec liftn_tomatch_stack n depth = function
   | [] -> []
-  | Pushed ((c,tm),l)::rest ->
+  | Pushed ((c,tm),l,dep)::rest ->
       let c = liftn n depth c in
       let tm = liftn_tomatch_type n depth tm in
       let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
+      Pushed ((c,tm),l,dep)::(liftn_tomatch_stack n depth rest)
   | Alias (c1,c2,d,t)::rest ->
       Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
       ::(liftn_tomatch_stack n depth rest)
@@ -658,7 +672,6 @@ let rec liftn_tomatch_stack n depth = function
       Abstract (map_rel_declaration (liftn n depth) d)
       ::(liftn_tomatch_stack n (depth+1) rest)
 
-
 let lift_tomatch_stack n = liftn_tomatch_stack n 1
 
 (* if [current] has type [I(p1...pn u1...um)] and we consider the case
@@ -686,7 +699,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_tabulate (fun _ -> Anonymous) (List.length sign) in
+  let names1 = list_make (List.length sign) Anonymous in
   (* If any, we prefer names used in pats, from top to bottom *)
   let names2 = 
     List.fold_right
@@ -753,17 +766,17 @@ let insert_aliases_eqn sign eqnnames alias_rest eqn =
       rhs = {eqn.rhs with rhs_env = push_rels thissign eqn.rhs.rhs_env } }
 
 let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
+  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
+  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
+  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
   let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
   let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
-  (* names2 takes the meet of all needed aliases *)
-  let names2 = 
+  (* name2 takes the meet of all needed aliases *)
+  let name2 = 
     List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
   (* Only needed aliases are kept by build_aliases_context *)
   let eqnsnames, sign1, sign2, env =
-    build_aliases_context env sigma [names2] eqnsnames [alias] in
+    build_aliases_context env sigma [name2] eqnsnames [alias] in
   let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
   sign2, env, eqns
 
@@ -771,28 +784,13 @@ let insert_aliases env sigma alias eqns =
 (* Functions to deal with elimination predicate *)
 
 exception Occur
-let noccur_between_without_evar n m term = 
+let noccur_between_without_evar n m term =
   let rec occur_rec n c = match kind_of_term c with
     | Rel p       -> if n<=p && p<n+m then raise Occur
     | Evar (_,cl) -> ()
     | _             -> iter_constr_with_binders succ occur_rec n c
   in 
-  try occur_rec n term; true with Occur -> false
-
-(* Infering the predicate *)
-let prepare_unif_pb typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-
-  (* We may need to invert ci if its parameters occur in typ *)
-  let typ' =
-    if noccur_between_without_evar 1 n typ then lift (-n) typ
-    else (* TODO4-1 *)
-      error "Unable to infer return clause of this pattern-matching problem" in
-  let args = extended_rel_list (-n) cs.cs_args in
-  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
-
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
-  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
+  (m = 0) or (try occur_rec n term; true with Occur -> false)
 
 
 (* Infering the predicate *)
@@ -823,8 +821,9 @@ the following n+1 equations:
 
 Some hints:
 
-- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
-  should be inserted somewhere in Ti.
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi)
+  => ..."  or a "psi(yk)", with psi extracting xij from uik, should be
+  inserted somewhere in Ti.
 
 - If T is undefined, an easy solution is to insert a "match z with (Ci
   xi1..xipi) => ..." in front of each Ti
@@ -834,111 +833,21 @@ Some hints:
 
 - The main problem is what to do when an existential variables is encountered
 
-let prepare_unif_pb typ cs =
-  let n = cs.cs_nargs in
-  let _,p = decompose_prod_n n typ in
-  let ci = build_dependent_constructor cs in
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
-  (n, cs.cs_concl_realargs, ci, p)
-
-let eq_operator_lift k (n,n') = function
-  | OpRel p, OpRel p' when p > k & p' > k ->
-      if p < k+n or p' < k+n' then false else p - n = p' - n'
-  | op, op' -> op = op'
-
-let rec transpose_args n =
-  if n=0 then []
-  else
-    (Array.map (fun l -> List.hd l) lv)::
-    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
-
-let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
-
-let reloc_operator (k,n) = function OpRel p when p > k -> 
-let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
-  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
-  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
-  then
-    let argvl = transpose_args (List.length args1) pv' in
-    let k' = shift_operator k op1 in
-    let argl = List.map (unify_clauses k') argvl in
-    gather_constr (reloc_operator (k,n1) op1) argl
-*)
-
-let abstract_conclusion typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-  let (sign,p) = decompose_prod_n n typ in
-  lam_it p sign
-
-let infer_predicate loc env isevars typs cstrs indf =
-  (* Il faudra substituer les isevars a un certain moment *)
-  if Array.length cstrs = 0 then (* "TODO4-3" *)
-    error "Inference of annotation for empty inductive types not implemented"
-  else
-    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
-    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
-    let typs =
-      Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs
-    in
-    let eqns = array_map2 prepare_unif_pb typs cstrs in
-    (* First strategy: no dependencies at all *)
-(*
-    let (mis,_) = dest_ind_family indf in
-    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
-*)
-    let (sign,_) = get_arity env indf in
-    let mtyp =
-      if array_exists is_Type typs then
-	(* Heuristic to avoid comparison between non-variables algebric univs*)
-	new_Type ()
-      else
-	mkExistential env ~src:(loc, Evd.CasesType) isevars
-    in
-    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
-    then
-      (* Non dependent case -> turn it into a (dummy) dependent one *)
-      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-      (true,pred) (* true = dependent -- par défaut *)
-    else
-(*
-      let s = get_sort_of env (evars_of isevars) typs.(0) in
-      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
-      let caseinfo = make_default_case_info mis in
-      let brs = array_map2 abstract_conclusion typs cstrs in
-      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-*)
-      (* "TODO4-2" *)
-      (* We skip parameters *)
-      let cis = 
-	Array.map
-	  (fun cs ->
-	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
-	  cstrs in
-      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
-      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
-(*
-      (true,pred)
 *)
 
 (* Propagation of user-provided predicate through compilation steps *)
 
-let rec map_predicate f k = function
-  | PrCcl ccl -> PrCcl (f k ccl)
-  | PrProd pred ->
-      PrProd (map_predicate f (k+1) pred)
-  | PrLetIn ((names,dep as tm),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      PrLetIn (tm, map_predicate f (k+k') pred)
-
-let rec noccurn_predicate k = function
-  | PrCcl ccl -> noccurn k ccl
-  | PrProd pred -> noccurn_predicate (k+1) pred
-  | PrLetIn ((names,dep),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      noccurn_predicate (k+k') pred
+let rec map_predicate f k ccl = function
+  | [] -> f k ccl
+  | Pushed ((_,tm),_,dep) :: rest ->
+      let k' = length_of_tomatch_type_sign dep tm in
+      map_predicate f (k+k') ccl rest
+  | Alias _ :: rest ->
+      map_predicate f k ccl rest
+  | Abstract _ :: rest ->
+      map_predicate f (k+1) ccl rest
+
+let noccurn_predicate = map_predicate noccurn
 
 let liftn_predicate n = map_predicate (liftn n)
 
@@ -949,26 +858,19 @@ let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
 let substnl_predicate sigma = map_predicate (substnl sigma)
 
 (* This is parallel bindings *)
-let subst_predicate (args,copt) pred =
+let subst_predicate (args,copt) ccl tms =
   let sigma = match copt with
     | None -> List.rev args
     | Some c -> c::(List.rev args) in
-  substnl_predicate sigma 0 pred
-
-let specialize_predicate_var (cur,typ) = function
-  | PrProd _ | PrCcl _ ->
-     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
-  | PrLetIn (([],dep),pred) ->
-      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
-  | PrLetIn ((_,dep),pred) ->
-      (match typ with
-        | IsInd (_,IndType (_,realargs)) ->
-           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
-        | _ -> anomaly "specialize_predicate_var")
-
-let ungeneralize_predicate = function
-  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
-  | PrProd pred -> pred
+  substnl_predicate sigma 0 ccl tms
+
+let specialize_predicate_var (cur,typ,dep) tms ccl =
+  let c = if dep<>Anonymous then Some cur else None in
+  let l = 
+    match typ with
+    | IsInd (_,IndType(_,realargs),names) -> if names<>[] then realargs else []
+    | NotInd _ -> [] in
+  subst_predicate (l,c) ccl tms
 
 (*****************************************************************************)
 (* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
@@ -979,85 +881,77 @@ let ungeneralize_predicate = function
 (* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
 (* then we have to replace x by x' in t(x) and y by y' in P                  *)
 (*****************************************************************************)
-let generalize_predicate c ny d = function
-  | PrLetIn ((names,dep as tm),pred) ->
-      if dep=Anonymous then anomaly "Undetected dependency";
-      let p = List.length names + 1 in
-      let pred = lift_predicate 1 pred in
-      let pred = regeneralize_index_predicate (ny+p+1) pred in
-      PrLetIn (tm, PrProd pred)
-  | PrProd _ | PrCcl _ ->
-      anomaly "generalize_predicate: expects a non trivial pattern"
-
-let rec extract_predicate l = function
-  | pred, Alias (deppat,nondeppat,_,_)::tms ->
+let generalize_predicate (names,(nadep,_)) ny d tms ccl =
+  if nadep=Anonymous then anomaly "Undetected dependency";
+  let p = List.length names + 1 in
+  let ccl = lift_predicate 1 ccl tms in
+  regeneralize_index_predicate (ny+p+1) ccl tms
+
+let rec extract_predicate l ccl = function
+  | Alias (deppat,nondeppat,_,_)::tms ->
       let tms' = match kind_of_term nondeppat with
         | Rel i -> replace_tomatch i deppat tms
         | _ -> (* initial terms are not dependent *) tms in
-      extract_predicate l (pred,tms')
-  | PrProd pred, Abstract d'::tms ->
+      extract_predicate l ccl tms'
+  | Abstract d'::tms ->
       let d' = map_rel_declaration (lift (List.length l)) d' in
-      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
-  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
+      substl l (mkProd_or_LetIn d' (extract_predicate [] ccl tms))
+  | Pushed ((cur,NotInd _),_,(dep,_))::tms ->
+      extract_predicate (if dep<>Anonymous then cur::l else l) ccl tms
+  | Pushed ((cur,IsInd (_,IndType(_,realargs),_)),_,(dep,_))::tms ->
       let l = List.rev realargs@l in
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrCcl ccl, [] ->
+      extract_predicate (if dep<>Anonymous then cur::l else l) ccl tms
+  | [] ->
       substl l ccl
-  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
-
-let abstract_predicate env sigma indf cur tms = function
-  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
-  | PrLetIn ((names,dep),pred) ->
-      let sign = make_arity_signature env true indf in
-      (* n is the number of real args + 1 *)
-      let n = List.length sign in
-      let tms = lift_tomatch_stack n tms in
-      let tms =
-        match kind_of_term cur with
-          | Rel i -> regeneralize_index_tomatch (i+n) tms
-          | _ -> (* Initial case *) tms in
-      (* Depending on whether the predicate is dependent or not, and has real
-         args or not, we lift it to make room for [sign] *)
-      (* Even if not intrinsically dep, we move the predicate into a dep one *)
-      let sign,q =
-        if names = [] & n <> 1 then
-          (* Real args were not considered *)
-          (if dep<>Anonymous then
-            (let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign)
-          else
-            sign),n
-        else
-          (* Real args are OK *)
-          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,1) in
-      let q,k = if dep <> Anonymous then (q-1,2) else (q,1) in
-      let pred = liftn_predicate q k pred in
-      let pred = extract_predicate [] (pred,tms) in
-      (true, it_mkLambda_or_LetIn_name env pred sign)
-
-let rec known_dependent = function
-  | None -> false
-  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
-  | Some (PrCcl _) -> false
-  | Some (PrProd _) ->
-      anomaly "known_dependent: can only be used when patterns remain"
+
+let abstract_predicate env sigma indf cur (names,(nadep,_)) tms ccl =
+  let sign = make_arity_signature env true indf in
+  (* n is the number of real args + 1 *)
+  let n = List.length sign in
+  let tms = lift_tomatch_stack n tms in
+  let tms =
+    match kind_of_term cur with
+      | Rel i -> regeneralize_index_tomatch (i+n) tms
+      | _ -> (* Initial case *) tms in
+  let sign = List.map2 (fun na (_,c,t) -> (na,c,t)) (nadep::names) sign in
+  let ccl = if nadep <> Anonymous then ccl else lift_predicate 1 ccl tms in 
+  let pred = extract_predicate [] ccl tms in
+  it_mkLambda_or_LetIn_name env pred sign
+
+let known_dependent (_,dep) = (dep = KnownDep)
 
 (* [expand_arg] is used by [specialize_predicate]
    it replaces gamma, x1...xn, x1...xk |- pred
    by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
    by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
 
-let expand_arg n alreadydep (na,t) deps (k,pred) =
-  (* current can occur in pred even if the original problem is not dependent *)
-  let dep =
-    if alreadydep<>Anonymous then alreadydep
-    else if deps = [] && noccurn_predicate 1 pred then Anonymous
-    else Name (id_of_string "x") in
-  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
-  (* There is no dependency in realargs for subpattern *)
-  (k-1, PrLetIn (([],dep), pred))
+let expand_arg tms ccl ((_,t),_,na) =
+  let k = length_of_tomatch_type_sign na t in 
+  lift_predicate (k-1) ccl tms
 
+let adjust_impossible_cases pb pred tomatch submat =
+  if submat = [] then
+    match kind_of_term (whd_evar (evars_of !(pb.evdref)) pred) with
+    | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) = ImpossibleCase ->
+	let default = (coq_unit_judge ()).uj_type in
+	pb.evdref := Evd.evar_define evk default !(pb.evdref);
+      (* we add an "assert false" case *)
+      let pats = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) tomatch in
+      let aliasnames =
+	map_succeed (function Alias _ -> Anonymous | _ -> failwith"") tomatch
+      in
+      [ { patterns = pats;
+          rhs = { rhs_env = pb.env; 
+	          rhs_vars = []; 
+		  avoid_ids = []; 
+		  it = None };
+	  alias_stack = Anonymous::aliasnames;
+	  eqn_loc = dummy_loc;
+	  used = ref false } ]
+    | _ ->
+	submat
+  else
+    submat
 
 (*****************************************************************************)
 (* pred = [X:=realargs;x:=c]P types the following problem:                   *)
@@ -1073,37 +967,35 @@ let expand_arg n alreadydep (na,t) deps (k,pred) =
 (* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
 (*                                                                           *)
 (*****************************************************************************)
-let specialize_predicate tomatchs deps cs = function
-  | (PrProd _ | PrCcl _) ->
-      anomaly "specialize_predicate: a matched pattern must be pushed"
-  | PrLetIn ((names,isdep),pred) ->
-      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
-      let nrealargs = List.length names in
-      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
-      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
-      let n = cs.cs_nargs in
-      let pred' = liftn_predicate n (k+1) pred in
-      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
-      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
-      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
-      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
-      let pred'' = subst_predicate (argsi, copti) pred' in
-      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
-      let pred''' = liftn_predicate n (n+1) pred'' in
-      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
-      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
-
-let find_predicate loc env isevars p typs cstrs current
-  (IndType (indf,realargs)) tms =
-  let (dep,pred) =
-    match p with
-      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
-      | None -> infer_predicate loc env isevars typs cstrs indf in
-  let typ = whd_beta (applist (pred, realargs)) in
-  if dep then
-    (pred, whd_beta (applist (typ, [current])), new_Type ())
-  else
-    (pred, typ, new_Type ())
+let specialize_predicate newtomatchs (names,(depna,_)) cs tms ccl =
+  (* Assume some gamma st: gamma, (X,x:=realargs,copt), tms |- ccl *)
+  let nrealargs = List.length names in
+  let k = nrealargs + (if depna<>Anonymous then 1 else 0) in
+  (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt), tms |- ccl' *)
+  let n = cs.cs_nargs in
+  let ccl' = liftn_predicate n (k+1) ccl tms in
+  let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
+  let copti = if depna<>Anonymous then Some (build_dependent_constructor cs) else None in
+  (* The substituends argsi, copti are all defined in gamma, x1...xn *)
+  (* We need _parallel_ bindings to get gamma, x1...xn, tms |- ccl'' *)
+  let ccl'' = whd_betaiota (subst_predicate (argsi, copti) ccl' tms) in
+  (* We adjust ccl st: gamma, x1..xn, x1..xn, tms |- ccl'' *)
+  let ccl''' = liftn_predicate n (n+1) ccl'' tms in
+  (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
+  List.fold_left (expand_arg tms) ccl''' newtomatchs
+
+let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms =
+  let pred= abstract_predicate env (evars_of !evdref) indf current dep tms p in
+  (pred, whd_betaiota (applist (pred, realargs@[current])), new_Type ())
+
+let adjust_predicate_from_tomatch ((_,oldtyp),_,(nadep,_)) typ pb =
+  match typ, oldtyp with
+  | IsInd (_,_,names), NotInd _ ->
+      let k = if nadep <> Anonymous then 2 else 1 in
+      let n = List.length names in
+      { pb with	pred = liftn_predicate n k pb.pred pb.tomatch }
+  | _ ->
+      pb
 
 (************************************************************************)
 (* Sorting equations by constructor *)
@@ -1144,7 +1036,6 @@ let group_equations pb ind current cstrs mat =
 	       (* This is a default clause that we expand *)
 	       for i=1 to Array.length cstrs do
 		 let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in
-		 let rest = {rest with tag = lower_pattern_status rest.tag} in
 		 brs.(i-1) <- (args, rest) :: brs.(i-1)
 	       done
 	   | PatCstr (loc,((_,i)),args,_) ->
@@ -1157,40 +1048,37 @@ let group_equations pb ind current cstrs mat =
 (* Here starts the pattern-matching compilation algorithm *)
 
 (* Abstracting over dependent subterms to match *)
-let rec generalize_problem pb current = function
+let rec generalize_problem names pb = function
   | [] -> pb
   | i::l ->
       let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
-      let pb' = generalize_problem pb current l in
+      let pb' = generalize_problem names pb l in
       let tomatch = lift_tomatch_stack 1 pb'.tomatch in
       let tomatch = regeneralize_index_tomatch (i+1) tomatch in
-      { pb with
+      { pb' with
 	  tomatch = Abstract d :: tomatch;
-          pred = option_map (generalize_predicate current i d) pb'.pred }
+          pred = generalize_predicate names i d pb.tomatch pb'.pred  }
 
 (* No more patterns: typing the right-hand-side of equations *)
 let build_leaf pb =
-  let tag, rhs = extract_rhs pb in
-  let tycon = match pb.pred with
-    | None -> empty_tycon
-    | Some (PrCcl typ) -> mk_tycon typ
-    | Some _ -> anomaly "not all parameters of pred have been consumed" in
-  tag, pb.typing_function tycon rhs.rhs_env rhs.it
+  let rhs = extract_rhs pb in
+  let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in
+  j_nf_evar (evars_of !(pb.evdref)) j
 
 (* Building the sub-problem when all patterns are variables *)
-let shift_problem (current,t) pb =
+let shift_problem ((current,t),_,(nadep,_)) pb =
   {pb with
      tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = option_map (specialize_predicate_var (current,t)) pb.pred;
+     pred = specialize_predicate_var (current,t,nadep) pb.tomatch pb.pred;
      history = push_history_pattern 0 AliasLeaf pb.history;
      mat = List.map remove_current_pattern pb.mat }
 
 (* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps pb eqns const_info =
+let build_branch current deps (realnames,dep) pb eqns const_info =
   (* We remember that we descend through a constructor *)
   let alias_type =
     if Array.length const_info.cs_concl_realargs = 0
-      & not (known_dependent pb.pred) & deps = []
+      & not (known_dependent dep) & deps = []
     then
       NonDepAlias
     else 
@@ -1202,24 +1090,21 @@ let build_branch current deps pb eqns const_info =
       pb.history in
 
   (* We find matching clauses *)
-  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
+  let cs_args = const_info.cs_args in
   let names = get_names pb.env cs_args eqns in
   let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
-  if submat = [] then
-    raise_pattern_matching_error
-      (dummy_loc, pb.env, NonExhaustive (complete_history history));
   let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
   let _,typs',_ =
     List.fold_right
       (fun (na,c,t as d) (env,typs,tms) ->
-	 let tm1 = List.map List.hd tms in
 	 let tms = List.map List.tl tms in
- 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
+ 	 (push_rel d env, (na,NotInd(c,t))::typs,tms))
       typs (pb.env,[],List.map fst eqns) in
 
   let dep_sign =
     find_dependencies_signature
-      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
+      (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) 
+      (List.rev typs) in
 
   (* The dependent term to subst in the types of the remaining UnPushed 
      terms is relative to the current context enriched by topushs *)
@@ -1231,11 +1116,25 @@ let build_branch current deps pb eqns const_info =
   (* into  "Gamma; typs; curalias |- tms" *)
   let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
 
-  let currents =
+  let typs'' = 
     list_map2_i
-      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
+      (fun i (na,t) deps ->
+	let dep = match dep with
+	  | Name _ as na',k -> (if na <> Anonymous then na else na'),k
+	  | Anonymous,KnownNotDep ->
+	      if deps = [] && noccurn_predicate 1 pb.pred tomatch then
+		(Anonymous,KnownNotDep)
+	      else
+		(force_name na,KnownDep)
+	  | _,_ -> anomaly "Inconsistent dependency" in
+	((mkRel i, lift_tomatch_type i t),deps,dep))
       1 typs' (List.rev dep_sign) in
 
+  let pred = 
+    specialize_predicate typs'' (realnames,dep) const_info tomatch pb.pred in
+
+  let currents = List.map (fun x -> Pushed x) typs'' in
+
   let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
 
   let ind =
@@ -1246,12 +1145,18 @@ let build_branch current deps pb eqns const_info =
 
   let cur_alias = lift (List.length sign) current in
   let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
+  let tomatch = List.rev_append currents tomatch in
+
+  let submat = adjust_impossible_cases pb pred tomatch submat in
+  if submat = [] then
+    raise_pattern_matching_error
+      (dummy_loc, pb.env, NonExhaustive (complete_history history));
 
   sign,
   { pb with
       env = push_rels sign pb.env;
-      tomatch = List.rev_append currents tomatch;
-      pred = option_map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred;
+      tomatch = tomatch;
+      pred = pred;
       history = history;
       mat = List.map (push_rels_eqn_with_names sign) submat }
 
@@ -1264,9 +1169,6 @@ let build_branch current deps pb eqns const_info =
   "Pushed" terms and types are relative to env
   "Abstract" types are relative to env enriched by the previous terms to match
 
-  Concretely, each term "c" or type "T" comes with a delayed lift
-  index, but it works as if the lifting were effective.
-
 *)
 
 (**********************************************************************)
@@ -1279,12 +1181,13 @@ let rec compile pb =
     | [] -> build_leaf pb
 
 and match_current pb tomatch =
-  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
+  let ((current,typ),deps,dep as ct) = adjust_tomatch_to_pattern pb tomatch in
+  let pb = adjust_predicate_from_tomatch tomatch typ pb in
   match typ with
     | NotInd (_,typ) ->
 	check_all_variables typ pb.mat;
 	compile (shift_problem ct pb)
-    | IsInd (_,(IndType(indf,realargs) as indt)) ->
+    | IsInd (_,(IndType(indf,realargs) as indt),names) ->
 	let mind,_ = dest_ind_family indf in
 	let cstrs = get_constructors pb.env indf in
 	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
@@ -1294,46 +1197,41 @@ and match_current pb tomatch =
           let _constraints = Array.map (solve_constraints indt) cstrs in
 
 	  (* We generalize over terms depending on current term to match *)
-	  let pb = generalize_problem pb current deps in
+	  let pb = generalize_problem (names,dep) pb deps in
 
 	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
+	  let brs = array_map2 (compile_branch current (names,dep) deps pb) eqns cstrs in
 
 	  (* We build the (elementary) case analysis *)
-	  let tags   = Array.map (fun (t,_,_) -> t) brs in
-	  let brvals = Array.map (fun (_,v,_) -> v) brs in
-	  let brtyps = Array.map (fun (_,_,t) -> t) brs in
+	  let brvals = Array.map (fun (v,_) -> v) brs in
 	  let (pred,typ,s) =
-	    find_predicate pb.caseloc pb.env pb.isevars 
-	      pb.pred brtyps cstrs current indt pb.tomatch in
-	  let ci = make_case_info pb.env mind RegularStyle tags in
+	    find_predicate pb.caseloc pb.env pb.evdref 
+	      pb.pred current indt (names,dep) pb.tomatch in
+	  let ci = make_case_info pb.env mind pb.casestyle in
 	  let case = mkCase (ci,nf_betaiota pred,current,brvals) in
 	  let inst = List.map mkRel deps in
-	  pattern_status tags,
 	  { uj_val = applist (case, inst);
 	    uj_type = substl inst typ }
 
-and compile_branch current deps pb eqn cstr =
-  let sign, pb = build_branch current deps pb eqn cstr in
-  let tag, j = compile pb in
-  (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+and compile_branch current names deps pb eqn cstr =
+  let sign, pb = build_branch current deps names pb eqn cstr in
+  let j = compile pb in
+  (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
 
 and compile_generalization pb d rest =
   let pb =
     { pb with
        env = push_rel d pb.env;
        tomatch = rest;
-       pred = option_map ungeneralize_predicate pb.pred;
        mat = List.map (push_rels_eqn [d]) pb.mat } in
-  let patstat,j = compile pb in
-  patstat, 
+  let j = compile pb in
   { uj_val = mkLambda_or_LetIn d j.uj_val;
     uj_type = mkProd_or_LetIn d j.uj_type }
 
 and compile_alias pb (deppat,nondeppat,d,t) rest =
   let history = simplify_history pb.history in
   let sign, newenv, mat =
-    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
+    insert_aliases pb.env (evars_of !(pb.evdref)) (deppat,nondeppat,d,t) pb.mat in
   let n = List.length sign in
 
   (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
@@ -1349,15 +1247,14 @@ and compile_alias pb (deppat,nondeppat,d,t) rest =
     {pb with
        env = newenv;
        tomatch = tomatch;
-       pred = option_map (lift_predicate n) pb.pred;
+       pred = lift_predicate n pb.pred tomatch;
        history = history;
        mat = mat } in
-  let patstat,j = compile pb in
-  patstat, 
+  let j = compile pb in
   List.fold_left mkSpecialLetInJudge j sign
 
 (* pour les alias des initiaux, enrichir les env de ce qu'il faut et
-substituer après par les initiaux *)
+substituer après par les initiaux *)
 
 (**************************************************************************)
 (* Preparation of the pattern-matching problem                            *)
@@ -1371,12 +1268,10 @@ let matx_of_eqns env tomatchl eqns =
     let initial_rhs = rhs in
     let rhs =
       { rhs_env = env;
+        rhs_vars = free_rawvars initial_rhs;
 	avoid_ids = ids@(ids_of_named_context (named_context env));
-	rhs_lift = 0;
-	it = initial_rhs } in
-    { dependencies = [];
-      patterns = initial_lpat;
-      tag = RegularPat;
+	it = Some initial_rhs } in
+    { patterns = initial_lpat;
       alias_stack = [];
       eqn_loc = loc;
       used = ref false;
@@ -1386,9 +1281,9 @@ let matx_of_eqns env tomatchl eqns =
 (************************************************************************)
 (* preparing the elimination predicate if any                          *)
 
-let build_expected_arity env isevars isdep tomatchl =
+let build_expected_arity env evdref isdep tomatchl =
   let cook n = function
-    | _,IsInd (_,IndType(indf,_)) ->
+    | _,IsInd (_,IndType(indf,_),_) ->
         let indf' = lift_inductive_family n indf in
 	Some (build_dependent_inductive env indf', fst (get_arity env indf'))
     | _,NotInd _ -> None
@@ -1415,7 +1310,7 @@ let build_expected_arity env isevars isdep tomatchl =
 
 let extract_predicate_conclusion isdep tomatchl pred =
   let cook = function
-    | _,IsInd (_,IndType(_,args)) -> Some (List.length args)
+    | _,IsInd (_,IndType(_,args),_) -> Some (List.length args)
     | _,NotInd _ -> None in
   let rec decomp_lam_force n l p =
     if n=0 then (l,p) else
@@ -1445,9 +1340,9 @@ let set_arity_signature dep n arsign tomatchl pred x =
   let rec decomp_lam_force n avoid l p =
     if n = 0 then (List.rev l,p,avoid) else
     match p with
-      | RLambda (_,(Name id as na),_,c) -> 
+      | RLambda (_,(Name id as na),_,_,c) -> 
           decomp_lam_force (n-1) (id::avoid) (na::l) c
-      | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c
+      | RLambda (_,(Anonymous as na),_,_,c) -> decomp_lam_force (n-1) avoid (na::l) c
       | _ ->
           let x = next_ident_away (id_of_string "x") avoid in
           decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
@@ -1458,7 +1353,7 @@ let set_arity_signature dep n arsign tomatchl pred x =
                | _ -> (RApp (dummy_loc,p,[a]))) in
   let rec decomp_block avoid p = function
     | ([], _) -> x := Some p
-    | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l')  ->
+    | ((_,IsInd (_,IndType(indf,realargs),_))::l),(y::l')  ->
 	let (ind,params) = dest_ind_family indf in
         let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p 
         in
@@ -1479,9 +1374,240 @@ let set_arity_signature dep n arsign tomatchl pred x =
   in
   decomp_block [] pred (tomatchl,arsign)
 
-let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
+(***************** Building an inversion predicate ************************)
+
+(* Let "match t1 in I1 u11..u1n_1 ... tm in Im um1..umn_m with ... end : T"
+   be a pattern-matching problem. We assume that the each uij can be
+   decomposed under the form pij(vij1..vijq_ij) where pij(aij1..aijq_ij)
+   is a pattern depending on some variables aijk and the vijk are
+   instances of these variables.  We also assume that each ti has the
+   form of a pattern qi(wi1..wiq_i) where qi(bi1..biq_i) is a pattern
+   depending on some variables bik and the wik are instances of these
+   variables (in practice, there is no reason that ti is already
+   constructed and the qi will be degenerated).
+
+   We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that 
+   T = U(..v1jk..t1 .. ..vmjk..tm). This a higher-order matching
+   problem with a priori different solution (one of them if T itself!).
+
+   We finally invert the uij and the ti and build the return clause
+
+   phi(x11..x1n_1y1..xm1..xmn_mym) =
+     match x11..x1n_1 y1 .. xm1..xmn_m ym with
+         | p11..p1n_1 q1 .. pm1..pmn_m qm => U(..a1jk..b1 .. ..amjk..bm)
+         |  _ .. _    _  ..  _ .. _    _  => True
+    end
+
+   so that "phi(u11..u1n_1t1..um1..umn_mtm) = T" (note that the clause
+   returning True never happens and any inhabited type can be put instead).
+*)
+
+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
+  (* 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:
+     - [subst] is made of pairs [(id,u)] where id is a name in [extenv] and
+       [u] a term typed in [env];
+     - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u]
+       and both are adjusted to [extenv] while [p] is the index of [id] in 
+       [extenv] (after expansion of the aliases) *)
+  let subst0 = map_succeed (fun (x,u) ->
+    (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *)
+    (* \--env-/          (= x:ty)         *)
+    (* \--------------extenv------------/ *)
+    let (p,_) = lookup_rel_id x (rel_context extenv) in
+    let rec aux n (_,b,ty) =
+      match b with
+      | Some c ->
+	  assert (isRel c);
+	  let p = n + destRel c in aux p (lookup_rel p (rel_context extenv))
+      | None ->
+	  (n,ty) in
+    let (p,ty) = aux p (lookup_rel p (rel_context extenv)) in
+    if noccur_between_without_evar 1 (n'-p-n+1) ty
+    then
+      let u = lift (n'-n) u in
+      (p,u,(expand_vars_in_term extenv u,lift p ty))
+    else
+      failwith "") subst in
+  let t0 = lift (n'-n) t in
+  (subst0,t0)
+
+(* Let vijk and ti be a set of dependent terms and T a type, all
+ * defined in some environment env. The vijk and ti are supposed to be
+ * instances for variables aijk and bi.
+ *
+ * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) 
+ * defined in some extended context 
+ * "Gamma0, ..a1jk:V1jk.. b1:W1 .. ..amjk:Vmjk.. bm:Wm"
+ * such that env |- T = U(..v1jk..t1 .. ..vmjk..tm). To not commit to
+ * a particular solution, we replace each subterm t in T that unifies with
+ * a subset u1..ul of the vijk and ti by a special evar
+ * ?id(x=t;c1:=c1,..,cl=cl) defined in context Gamma0,x,c1,...,cl |- ?id
+ * (where the c1..cl are the aijk and bi matching the u1..ul), and
+ * similarly for each ti.
+*)
+
+let abstract_tycon loc env evdref subst _tycon extenv t =
+  let t = nf_betaiota t in (* it helps in some cases to remove K-redex... *)
+  let sigma = evars_of !evdref in
+  let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv subst t in
+  (* We traverse the type T of the original problem Xi looking for subterms
+     that match the non-constructor part of the constraints (this part
+     is in subst); these subterms are the "good" subterms and we replace them
+     by an evar that may depend (and only depend) on the corresponding
+     convertible subterms of the substitution *)
+  let rec aux (k,env,subst as x) t =
+    let good = List.filter (fun (_,u,_) -> is_conv_leq env sigma t u) subst in
+    if good <> [] then
+      let (u,ty) = pi3 (List.hd good) in
+      let vl = List.map pi1 good in
+      let inst = 
+	list_map_i
+	  (fun i _ -> if List.mem i vl then u else mkRel i) 1
+	  (rel_context extenv) in
+      let rel_filter = 
+	List.map (fun a -> not (isRel a) or dependent a u) inst in
+      let named_filter =
+	List.map (fun (id,_,_) -> dependent (mkVar id) u)
+	  (named_context extenv) in
+      let filter = rel_filter@named_filter in
+      let ev =
+	e_new_evar evdref extenv ~src:(loc, CasesType) ~filter:filter ty in
+      evdref := add_conv_pb (Reduction.CONV,extenv,substl inst ev,u) !evdref;
+      lift k ev
+    else
+      map_constr_with_full_binders 
+	(fun d (k,env,subst) ->
+	  k+1,
+	  push_rel d env, 
+	  List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst)
+	aux x t in
+  aux (0,extenv,subst0) t0
+
+let build_tycon loc env tycon_env subst tycon extenv evdref t =
+  let t = match t with
+    | 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 impossible_case_type = 
+	  e_new_evar evdref env ~src:(loc,ImpossibleCase) (new_Type ()) in
+	lift (n'-n) impossible_case_type
+    | Some t -> abstract_tycon loc tycon_env evdref subst tycon extenv t in
+  get_judgment_of extenv (evars_of !evdref) t
+
+(* For a multiple pattern-matching problem Xi on t1..tn with return
+ * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return
+ * predicate for Xi that is itself made by an auxiliary 
+ * pattern-matching problem of which the first clause reveals the
+ * pattern structure of the constraints on the inductive types of the t1..tn,
+ * and the second clause is a wildcard clause for catching the
+ * impossible cases. See above "Building an inversion predicate" for
+ * further explanations
+ *)
+
+let build_inversion_problem loc env evdref tms t =
+  let sigma = evars_of !evdref in
+  let make_patvar t (subst,avoid) =
+    let id = next_name_away (named_hd env t Anonymous) avoid in
+    PatVar (dummy_loc,Name id), ((id,t)::subst, id::avoid) in
+  let rec reveal_pattern t (subst,avoid as acc) =
+    match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Construct cstr -> PatCstr (dummy_loc,cstr,[],Anonymous), acc
+    | App (f,v) when isConstruct f ->
+	let cstr = destConstruct f in
+	let n = constructor_nrealargs env cstr in
+	let l = list_lastn n (Array.to_list v) in
+	let l,acc = list_fold_map' reveal_pattern l acc in
+	PatCstr (dummy_loc,cstr,l,Anonymous), acc
+    | _ -> make_patvar t acc in
+  let rec aux n env acc_sign tms acc =
+    match tms with
+    | [] -> [], acc_sign, acc
+    | (t, IsInd (_,IndType(indf,realargs),_)) :: tms ->
+	let patl,acc = list_fold_map' reveal_pattern realargs acc in
+	let pat,acc = make_patvar t acc in
+	let indf' = lift_inductive_family n indf in
+	let sign = make_arity_signature env true indf' in
+	let p = List.length realargs in
+	let env' = push_rels sign env in
+	let patl',acc_sign,acc = aux (n+p+1) env' (sign@acc_sign) tms acc in
+	patl@pat::patl',acc_sign,acc
+    | (t, NotInd (bo,typ)) :: tms ->
+	aux n env acc_sign tms acc in
+  let avoid0 = ids_of_context env in
+  (* [patl] is a list of patterns revealing the substructure of
+     constructors present in the constraints on the type of the
+     multiple terms t1..tn that are matched in the original problem;
+     [subst] is the substitution of the free pattern variables in
+     [patl] that returns the non-constructor parts of the constraints.
+     Especially, if the ti has type I ui1..uin_i, and the patterns associated
+     to ti are pi1..pin_i, then subst(pij) is uij; the substitution is
+     useful to recognize which subterms of the whole type T of the original
+     problem have to be abstracted *)
+  let patl,sign,(subst,avoid) = aux 0 env [] tms ([],avoid0) in
+  let n = List.length sign in
+  let (pb_env,_),sub_tms =
+    list_fold_map (fun (env,i) (na,b,t as d) ->
+      let typ =
+	if b<>None then NotInd(None,t) else
+	  try try_find_ind env sigma t None
+	  with Not_found -> NotInd (None,t) in
+      let ty = lift_tomatch_type (n-i) typ in
+      let tm = Pushed ((mkRel (n-i),ty),[],(Anonymous,KnownNotDep)) in
+      ((push_rel d env,i+1),tm))
+      (env,0) (List.rev sign) in
+  let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
+  (* [eqn1] is the first clause of the auxiliary pattern-matching that
+     serves as skeleton for the return type: [patl] is the
+     substructure of constructors extracted from the list of
+     constraints on the inductive types of the multiple terms matched
+     in the original pattern-matching problem Xi *)
+  let eqn1 =
+    { patterns = patl;
+      alias_stack = [];
+      eqn_loc = dummy_loc;
+      used = ref false;
+      rhs = { rhs_env = pb_env;
+              (* we assume all vars are used; in practice we discard dependent
+		 vars so that the field rhs_vars is normally not used *)
+              rhs_vars = List.map fst subst;
+              avoid_ids = avoid;
+	      it = Some (lift n t) } } in
+  (* [eqn2] is the default clause of the auxiliary pattern-matching: it will
+     catch the clauses of the original pattern-matching problem Xi whose
+     type constraints are incompatible with the constraints on the
+     inductive types of the multiple terms matched in Xi *)
+  let eqn2 =
+    { patterns = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) patl;
+      alias_stack = [];
+      eqn_loc = dummy_loc;
+      used = ref false;
+      rhs = { rhs_env = pb_env; 
+              rhs_vars = []; 
+	      avoid_ids = avoid0;
+	      it = None } } in
+  (* [pb] is the auxiliary pattern-matching serving as skeleton for the 
+      return type of the original problem Xi *)
+  let pb =
+    { env       = pb_env;
+      evdref    = evdref;
+      pred      = new_Type();
+      tomatch   = sub_tms;
+      history   = start_history n;
+      mat       = [eqn1;eqn2];
+      caseloc   = loc;
+      casestyle = RegularStyle;
+      typing_function = build_tycon loc env pb_env subst} in
+  (compile pb).uj_val
+
+let prepare_predicate_from_tycon loc dep env evdref tomatchs sign c =
   let cook (n, l, env, signs) = function
-    | c,IsInd (_,IndType(indf,realargs)) ->
+    | c,IsInd (_,IndType(indf,realargs),_) ->
 	let indf' = lift_inductive_family n indf in
 	let sign = make_arity_signature env dep indf' in
 	let p = List.length realargs in
@@ -1489,59 +1615,47 @@ let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
 	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
 	else
 	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
-    | c,NotInd _ ->
-	(n, l, env, []::signs) in
-  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+    | c,NotInd (bo,typ) ->
+	let sign = [Anonymous,Option.map (lift n) bo,lift n typ] in
+	let sign = name_context env sign in
+	(n + 1, c::l, push_rels sign env, sign::signs) in
+  let n,allargs,env',signs = List.fold_left cook (0, [], env, []) tomatchs in
   let names = List.rev (List.map (List.map pi1) signs) in
-  let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
-  let rec build_skeleton env c =
-    (* Don't put into normal form, it has effects on the synthesis of evars *)
- (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
-    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
-    if isEvar c or List.exists (eq_constr c) allargs then
-      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
-        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
-    else
-      map_constr_with_full_binders push_rel build_skeleton env c 
-  in
-    names, build_skeleton env (lift n c)
+  names, build_inversion_problem loc env evdref tomatchs c
   
 (* Here, [pred] is assumed to be in the context built from all *)
 (* realargs and terms to match *)
-let build_initial_predicate isdep allnames pred =
+let build_initial_predicate knowndep allnames pred =
   let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let rec buildrec n pred = function
-    | [] -> PrCcl pred
+  let rec buildrec n pred nal = function
+    | [] -> List.rev nal,pred
     | names::lnames ->
-        let names' = if isdep then List.tl names else names in
+        let names' = List.tl names in
         let n' = n + List.length names' in
-        let pred, p, user_p =
-          if isdep then 
-            if dependent (mkRel (nar-n')) pred then pred, 1, 1
-            else liftn (-1) (nar-n') pred, 0, 1
-          else pred, 0, 0 in
+        let pred, p =
+          if dependent (mkRel (nar-n')) pred then pred, 1
+          else liftn (-1) (nar-n') pred, 0 in
         let na =
           if p=1 then
             let na = List.hd names in
-            if na = Anonymous then
-              (* peut arriver en raison des evars *)
+            ((if na = Anonymous then
+              (* can happen if evars occur in the return clause *)
               Name (id_of_string "x") (*Hum*)
-            else na
-          else Anonymous in
-        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
-  in buildrec 0 pred allnames
+            else na),knowndep)
+          else (Anonymous,KnownNotDep) in
+        buildrec (n'+1) pred (na::nal) lnames
+  in buildrec 0 pred [] allnames
 
 let extract_arity_signature env0 tomatchl tmsign =
   let get_one_sign n tm (na,t) =
     match tm with
       | NotInd (bo,typ) -> 
 	  (match t with
-	    | None -> [na,option_map (lift n) bo,lift n typ]
+	    | None -> [na,Option.map (lift n) bo,lift n typ]
 	    | Some (loc,_,_,_) -> 
  	    user_err_loc (loc,"",
 	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
+      | IsInd (term,IndType(indf,realargs),_) ->
           let indf' = lift_inductive_family n indf in
 	  let (ind,params) = dest_ind_family indf' in
 	  let nrealargs = List.length realargs in
@@ -1554,8 +1668,16 @@ let extract_arity_signature env0 tomatchl tmsign =
 		    or nrealargs <> List.length realnal then
 		      anomaly "Ill-formed 'in' clause in cases";
 		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+	      | None -> list_make nrealargs Anonymous in
 	  let arsign = fst (get_arity env0 indf') in
+(* 	  let na =  *)
+(* 	    match na with  *)
+(* 	      | Name _ -> na *)
+(* 	      | Anonymous -> *)
+(* 		  match kind_of_term term with *)
+(* 		    | Rel n -> pi1 (lookup_rel n (Environ.rel_context env0)) *)
+(* 		    | _ -> Anonymous *)
+(* 	  in *)
 	  (na,None,build_dependent_inductive env0 indf')
 	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
   let rec buildrec n = function
@@ -1566,14 +1688,55 @@ let extract_arity_signature env0 tomatchl tmsign =
     | _ -> assert false
   in List.rev (buildrec 0 (tomatchl,tmsign))
 
-let inh_conv_coerce_to_tycon loc env isevars j tycon =
+let inh_conv_coerce_to_tycon loc env evdref j tycon =
   match tycon with
     | Some p ->
-	let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
-          isevars := evd';
+	let (evd',j) = Coercion.inh_conv_coerce_to loc env !evdref j p in
+          evdref := evd';
           j
     | None -> j
 
+(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
+
+let prepare_predicate_from_arsign_tycon loc env tomatchs sign 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 ->
+      let signlen = List.length sign in
+	match kind_of_term tm with
+	  | Rel n when dependent tm c 
+		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
+	      ((n, len) :: subst, len - signlen)
+	  | Rel _ when not (dependent tm c)
+		&& signlen > 1 (* The term is of a dependent type but does not appear in 
+				  the tycon, maybe some variable in its type does. *) ->
+	      (match tmtype with
+		  NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+		| IsInd (_, IndType(indf,realargs),_) ->
+		    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 - signlen))
+      ([], nar) tomatchs arsign
+  in
+  let rec predicate lift c =
+    match kind_of_term c with
+      | Rel n when n > lift -> 
+	  (try 
+	      (* Make the predicate dependent on the matched variable *)
+	      let idx = List.assoc (n - lift) subst in
+		mkRel (idx + lift)
+	    with Not_found -> 
+	      (* A variable that is not matched, lift over the arsign. *)
+	      mkRel (n + nar))
+      | _ ->
+	  map_constr_with_binders succ predicate lift c 
+  in predicate 0 c
+
 
 (* Builds the predicate. If the predicate is dependent, its context is
  * made of 1+nrealargs assumptions for each matched term in an inductive
@@ -1582,18 +1745,58 @@ let inh_conv_coerce_to_tycon loc env isevars j tycon =
 
  * Each matched terms are independently considered dependent or not.
 
- * A type constraint but no annotation case: it is assumed non dependent.
+ * A type constraint but no annotation case: we try to specialize the
+ * tycon to make the predicate if it is not closed.
  *)
 
-let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function
+let is_dependent_on_rel x t =
+  match kind_of_term x with
+      Rel n -> not (noccur_with_meta n n t)
+    | _ -> false
+
+let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred =
+  match pred with
   (* No type annotation *)
   | None ->
       (match tycon with
+       | Some (None, t) when not (noccur_with_meta 0 max_int t) ->
+	   (* If the tycon is not closed w.r.t real variables *)
+	   (* We try two different strategies *)
+	   let evdref2 = ref !evdref in
+           let arsign = extract_arity_signature env tomatchs sign in
+           let env' = List.fold_right push_rels arsign env in
+	   (* First strategy: we abstract the tycon wrt to the dependencies *)
+           let names1 = List.rev (List.map (List.map pi1) arsign) in
+           let pred1 = prepare_predicate_from_arsign_tycon loc env' tomatchs sign arsign t in
+           let nal1,pred1 = build_initial_predicate KnownDep names1 pred1 in
+	   (* Second strategy: we build an "inversion" predicate *)
+	   let names2,pred2 = 
+	     prepare_predicate_from_tycon loc true env evdref2 tomatchs sign t
+	   in 
+	   let nal2,pred2 = build_initial_predicate DepUnknown names2 pred2 in
+	   [evdref, nal1, pred1; evdref2, nal2, pred2]
        | Some (None, t) ->
+	   (* Only one strategy: we build an "inversion" predicate *)
 	   let names,pred = 
-	     prepare_predicate_from_tycon loc false env isevars tomatchs sign t 
-	   in Some (build_initial_predicate false names pred)
-       | _ -> None)
+	     prepare_predicate_from_tycon loc true env evdref tomatchs sign t
+	   in 
+	   let nal,pred = build_initial_predicate DepUnknown names pred in
+	   [evdref, nal, pred]
+       | _ ->
+	   (* No type constaints: we use two strategies *)
+	   let evdref2 = ref !evdref in
+	   let t1 = mkExistential env ~src:(loc, CasesType) evdref in
+	   (* First strategy: we pose a possibly dependent "inversion" evar *)
+	   let names1,pred1 = 
+	     prepare_predicate_from_tycon loc true env evdref tomatchs sign t1
+	   in 
+	   let nal1,pred1 = build_initial_predicate DepUnknown names1 pred1 in
+	   (* Second strategy: we pose a non dependent evar *)
+	   let t2 = mkExistential env ~src:(loc, CasesType) evdref2 in
+           let arsign = extract_arity_signature env tomatchs sign in
+           let names2 = List.rev (List.map (List.map pi1) arsign) in
+	   let nal2,pred2 = build_initial_predicate KnownNotDep names2 t2 in
+	   [evdref, nal1, pred1; evdref2, nal2, pred2])
 
   (* Some type annotation *)
   | Some rtntyp ->
@@ -1601,50 +1804,69 @@ let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function
       let arsign = extract_arity_signature env tomatchs sign in
       let env = List.fold_right push_rels arsign env in
       let allnames = List.rev (List.map (List.map pi1) arsign) in
-      let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in
+      let predcclj = typing_fun (mk_tycon (new_Type ())) env evdref rtntyp in
       let _ = 
-	option_map (fun tycon -> 
-		      isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val 
+	Option.map (fun tycon -> 
+		      evdref := Coercion.inh_conv_coerces_to loc env !evdref predcclj.uj_val 
 		      (lift_tycon_type (List.length arsign) tycon))
 	  tycon
       in
-      let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
-	Some (build_initial_predicate true allnames predccl)
+      let predccl = (j_nf_isevar !evdref predcclj).uj_val in      
+      let nal,pred = build_initial_predicate KnownDep allnames predccl in
+      [evdref, nal, pred]
 
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
   
-let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)=
-  
+let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
+
   (* We build the matrix of patterns and right-hand-side *)
   let matx = matx_of_eqns env tomatchl eqns in
     
   (* We build the vector of terms to match consistently with the *)
   (* constructors found in patterns *)
-  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
-    
-  (* We build the elimination predicate if any and check its consistency *)
-  (* with the type of arguments to match *)
-  let tmsign = List.map snd tomatchl in
-  let pred = prepare_predicate loc typing_fun isevars env tomatchs tmsign tycon predopt in
-    
-  (* 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 initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+  let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in
     
-  let pb =
-    { env      = env;
-      isevars  = isevars;
-      pred     = pred;
-      tomatch  = initial_pushed;
-      history  = start_history (List.length initial_pushed);
-      mat      = matx;
-      caseloc  = loc;
-      typing_function = typing_fun } in
+  (* If an elimination predicate is provided, we check it is compatible
+     with the type of arguments to match; if none is provided, we
+     build alternative possible predicates *)
+  let sign = List.map snd tomatchl in
+  let preds = prepare_predicate loc typing_fun evdref env tomatchs sign tycon predopt in
     
-  let _, j = compile pb in
-    (* We check for unused patterns *)
-    List.iter (check_unused_pattern env) matx;
-    inh_conv_coerce_to_tycon loc env isevars j tycon
+  let compile_for_one_predicate (myevdref,nal,pred) =
+    (* 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 initial_pushed = List.map2 (fun tm na -> Pushed(tm,[],na)) tomatchs nal in
+
+    (* A typing function that provides with a canonical term for absurd cases*)
+    let typing_fun tycon env evdref = function
+    | Some t ->	typing_fun tycon env evdref t
+    | None -> coq_unit_judge () in
+
+    let pb =
+      { env       = env;
+        evdref    = myevdref;
+	pred      = pred;
+	tomatch   = initial_pushed;
+	history   = start_history (List.length initial_pushed);
+	mat       = matx;
+	caseloc   = loc;
+	casestyle = style;
+	typing_function = typing_fun } in
+
+    let j = compile pb in
+    evdref := !myevdref;
+    j in
+
+  (* Return the term compiled with the first possible elimination  *)
+  (* predicate for which the compilation succeeds *)
+  let j = list_try_compile compile_for_one_predicate preds in
+
+  (* We check for unused patterns *)
+  List.iter (check_unused_pattern env) matx;
+
+  (* We coerce to the tycon (if an elim predicate was provided) *)
+  inh_conv_coerce_to_tycon loc env evdref j tycon
+
 end
-  
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 30f68083..98923b2a 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cases.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
+(*i $Id: cases.mli 11014 2008-05-28 19:09:32Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -46,14 +46,27 @@ val error_wrong_predicate_arity_loc : loc -> env -> constr -> constr -> constr -
 
 val error_needs_inversion : env -> constr -> types -> 'a
 
+val set_impossible_default_clause : constr * types -> unit
 (*s Compilation of pattern-matching. *)
 
+type alias_constr =
+  | DepAlias
+  | NonDepAlias
+type dep_status = KnownDep | KnownNotDep | DepUnknown
+type tomatch_type =
+  | IsInd of types * inductive_type * name list
+  | NotInd of constr option * types
+type tomatch_status =
+  | Pushed of ((constr * tomatch_type) * int list * (name * dep_status))
+  | Alias of (constr * constr * alias_constr * constr)
+  | Abstract of rel_declaration
+
 module type S = sig
   val compile_cases :
-    loc ->
-    (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref ->
+    loc -> case_style ->
+    (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref ->
     type_constraint -> 
-    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    env -> rawconstr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
 
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index bbad005c..83ba05bb 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: classops.ml 9257 2006-10-21 17:28:28Z herbelin $ *)
+(* $Id: classops.ml 10840 2008-04-23 21:29:34Z herbelin $ *)
 
 open Util
 open Pp
-open Options
+open Flags
 open Names
 open Libnames
 open Nametab
@@ -44,7 +44,7 @@ type coe_typ = global_reference
 type coe_info_typ = {
   coe_value : constr;
   coe_type : types;
-  coe_strength : strength;
+  coe_strength : locality;
   coe_is_identity : bool;
   coe_param : int }
 
@@ -290,7 +290,7 @@ let add_coercion_in_graph (ic,source,target) =
   if (!ambig_paths <> []) && is_verbose () then 
     ppnl (message_ambig !ambig_paths)
 
-type coercion = coe_typ * strength * bool * cl_typ * cl_typ * int
+type coercion = coe_typ * locality * bool * cl_typ * cl_typ * int
 
 (* Calcul de l'arité d'une classe *)
 
@@ -304,7 +304,7 @@ let class_params = function
   | CL_SECVAR sp -> reference_arity_length (VarRef sp)
   | CL_IND sp  -> reference_arity_length (IndRef sp)
 
-(* add_class : cl_typ -> strength option -> bool -> unit *)
+(* add_class : cl_typ -> locality_flag option -> bool -> unit *)
 
 let add_class cl =
   add_new_class cl { cl_param = class_params cl }
@@ -366,12 +366,14 @@ let coercion_identity v = v.coe_is_identity
 (* For printing purpose *)
 let get_coercion_value v = v.coe_value
 
+let pr_cl_index n = int n
+
 let classes () = Bijint.dom !class_tab
 let coercions () = Gmap.rng !coercion_tab
 let inheritance_graph () = Gmap.to_list !inheritance_graph
 
-let coercion_of_qualid qid =
-  let ref = Nametab.global qid in
+let coercion_of_reference r =
+  let ref = Nametab.global r in
   if not (coercion_exists ref) then
     errorlabstrm "try_add_coercion" 
       (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion");
@@ -380,7 +382,7 @@ let coercion_of_qualid qid =
 module CoercionPrinting =
   struct
     type t = coe_typ
-    let encode = coercion_of_qualid
+    let encode = coercion_of_reference
     let subst = subst_coe_typ
     let printer x = pr_global_env Idset.empty x
     let key = Goptions.SecondaryTable ("Printing","Coercion")
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index 276b14d1..1436a11b 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
+(*i $Id: classops.mli 10840 2008-04-23 21:29:34Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -66,7 +66,7 @@ val class_args_of : constr -> constr list
 
 (*s [declare_coercion] adds a coercion in the graph of coercion paths *)
 val declare_coercion : 
-  coe_typ -> strength -> isid:bool ->
+  coe_typ -> locality -> isid:bool ->
       src:cl_typ -> target:cl_typ -> params:int -> unit
 
 (*s Access to coercions infos *)
@@ -90,6 +90,7 @@ val install_path_printer :
 (*s This is for printing purpose *)
 val string_of_class : cl_typ -> string
 val pr_class : cl_typ -> std_ppcmds
+val pr_cl_index : cl_index -> std_ppcmds
 val get_coercion_value : coe_index -> constr
 val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list
 val classes : unit -> cl_typ list
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml
index 29dbe83d..03f84809 100644
--- a/pretyping/clenv.ml
+++ b/pretyping/clenv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenv.ml 9665 2007-02-21 17:08:10Z herbelin $ *)
+(* $Id: clenv.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -21,18 +21,14 @@ open Reduction
 open Reductionops
 open Rawterm
 open Pattern
-open Tacexpr
 open Tacred
 open Pretype_errors
 open Evarutil
 open Unification
 open Mod_subst
+open Coercion.Default
 
-(* *)
-let w_coerce env c ctyp target evd =
-  let j = make_judge c ctyp in
-  let (evd',j') = Coercion.Default.inh_conv_coerce_to dummy_loc env evd j (mk_tycon_type target) in
-  (evd',j'.uj_val)
+(* Abbreviations *)
 
 let pf_env gls = Global.env_of_context gls.it.evar_hyps
 let pf_type_of gls c  = Typing.type_of (pf_env gls) gls.sigma c
@@ -43,36 +39,31 @@ let pf_concl gl = gl.it.evar_concl
 (* Clausal environments *)
 
 type clausenv = {
-  templenv : env;
-  env      : evar_defs;
+  env      : env;
+  evd      : evar_defs;
   templval : constr freelisted;
   templtyp : constr freelisted }
 
-let cl_env ce = ce.templenv
-let cl_sigma ce = evars_of ce.env
+let cl_env ce = ce.env
+let cl_sigma ce = evars_of ce.evd
 
 let subst_clenv sub clenv = 
   { templval = map_fl (subst_mps sub) clenv.templval;
     templtyp = map_fl (subst_mps sub) clenv.templtyp;
-    env = subst_evar_defs_light sub clenv.env;
-    templenv = clenv.templenv }
+    evd = subst_evar_defs_light sub clenv.evd;
+    env = clenv.env }
 
-let clenv_nf_meta clenv c = nf_meta clenv.env c
-let clenv_meta_type clenv mv = Typing.meta_type clenv.env mv
-let clenv_value clenv = meta_instance clenv.env clenv.templval
-let clenv_type clenv = meta_instance clenv.env clenv.templtyp
+let clenv_nf_meta clenv c = nf_meta clenv.evd c
+let clenv_term clenv c = meta_instance clenv.evd c
+let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv
+let clenv_value clenv = meta_instance clenv.evd clenv.templval
+let clenv_type clenv = meta_instance clenv.evd clenv.templtyp
 
 
 let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t
 
 let clenv_get_type_of ce c =
-  let metamap =
-    List.map 
-      (function
-	 | (n,Clval(_,_,typ)) -> (n,typ.rebus)
-         | (n,Cltyp (_,typ))    -> (n,typ.rebus))
-      (meta_list ce.env) in
-  Retyping.get_type_of_with_meta (cl_env ce) (cl_sigma ce) metamap c
+  Retyping.get_type_of_with_meta (cl_env ce) (cl_sigma ce) (metas_of ce.evd) c
 
 exception NotExtensibleClause
 
@@ -84,62 +75,76 @@ let clenv_push_prod cl =
 	let mv = new_meta () in
 	let dep = dependent (mkRel 1) u in
 	let na' = if dep then na else Anonymous in
-	let e' = meta_declare mv t ~name:na' cl.env in
+	let e' = meta_declare mv t ~name:na' cl.evd in
 	let concl = if dep then subst1 (mkMeta mv) u else u in
 	let def = applist (cl.templval.rebus,[mkMeta mv]) in
 	{ templval = mk_freelisted def;
 	  templtyp = mk_freelisted concl;
-	  env = e';
-	  templenv = cl.templenv }
+	  evd = e';
+	  env = cl.env }
     | _ -> raise NotExtensibleClause
   in clrec typ
 
-let clenv_environments evd bound c =
-  let rec clrec (e,metas) n c =
-    match n, kind_of_term c with
-      | (Some 0, _) -> (e, List.rev metas, c)
-      | (n, Cast (c,_,_)) -> clrec (e,metas) n c
-      | (n, Prod (na,c1,c2)) ->
+(* Instantiate the first [bound] products of [t] with metas (all products if
+   [bound] is [None]; unfold local defs *)
+
+let clenv_environments evd bound t =
+  let rec clrec (e,metas) n t =
+    match n, kind_of_term t with
+      | (Some 0, _) -> (e, List.rev metas, t)
+      | (n, Cast (t,_,_)) -> clrec (e,metas) n t
+      | (n, Prod (na,t1,t2)) ->
 	  let mv = new_meta () in
-	  let dep = dependent (mkRel 1) c2 in
+	  let dep = dependent (mkRel 1) t2 in
 	  let na' = if dep then na else Anonymous in
-	  let e' = meta_declare mv c1 ~name:na' e in
-	  clrec (e', (mkMeta mv)::metas) (option_map ((+) (-1)) n)
-	    (if dep then (subst1 (mkMeta mv) c2) else c2)
-      | (n, LetIn (na,b,_,c)) ->
-	  clrec (e,metas) (option_map ((+) (-1)) n) (subst1 b c)
-      | (n, _) -> (e, List.rev metas, c)
+	  let e' = meta_declare mv t1 ~name:na' e in
+	  clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n)
+	    (if dep then (subst1 (mkMeta mv) t2) else t2)
+      | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t)
+      | (n, _) -> (e, List.rev metas, t)
   in 
-  clrec (evd,[]) bound c
-
-let clenv_environments_evars env evd bound c =
-  let rec clrec (e,ts) n c =
-    match n, kind_of_term c with
-      | (Some 0, _) -> (e, List.rev ts, c)
-      | (n, Cast (c,_,_)) -> clrec (e,ts) n c
-      | (n, Prod (na,c1,c2)) ->
-          let e',constr = Evarutil.new_evar e env c1 in
-	  let dep = dependent (mkRel 1) c2 in
-	  clrec (e', constr::ts) (option_map ((+) (-1)) n)
-	    (if dep then (subst1 constr c2) else c2)
-      | (n, LetIn (na,b,_,c)) ->
-	  clrec (e,ts) (option_map ((+) (-1)) n) (subst1 b c)
-      | (n, _) -> (e, List.rev ts, c)
+  clrec (evd,[]) bound t
+
+(* Instantiate the first [bound] products of [t] with evars (all products if
+   [bound] is [None]; unfold local defs *)
+
+let clenv_environments_evars env evd bound t =
+  let rec clrec (e,ts) n t =
+    match n, kind_of_term t with
+      | (Some 0, _) -> (e, List.rev ts, t)
+      | (n, Cast (t,_,_)) -> clrec (e,ts) n t
+      | (n, Prod (na,t1,t2)) ->
+          let e',constr = Evarutil.new_evar e env t1 in
+	  let dep = dependent (mkRel 1) t2 in
+	  clrec (e', constr::ts) (Option.map ((+) (-1)) n)
+	    (if dep then (subst1 constr t2) else t2)
+      | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t)
+      | (n, _) -> (e, List.rev ts, t)
   in 
-  clrec (evd,[]) bound c
-
-let mk_clenv_from_n gls n (c,cty) =
-  let evd = create_evar_defs gls.sigma in
+  clrec (evd,[]) bound t
+
+let clenv_conv_leq env sigma t c bound =
+  let ty = Retyping.get_type_of env sigma c in
+  let evd = Evd.create_goal_evar_defs sigma in
+  let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in
+  let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in
+  let evars,_ = Evarconv.consider_remaining_unif_problems env evars in
+  let args = List.map (whd_evar (Evd.evars_of evars)) args in
+  check_evars env sigma evars (applist (c,args));
+  args
+
+let mk_clenv_from_env environ sigma n (c,cty) =
+  let evd = create_goal_evar_defs sigma in
   let (env,args,concl) = clenv_environments evd n cty in
   { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
     templtyp = mk_freelisted concl;
-    env = env;
-    templenv = Global.env_of_context gls.it.evar_hyps }
+    evd = env;
+    env = environ }
 
-let mk_clenv_from gls = mk_clenv_from_n gls None
+let mk_clenv_from_n gls n (c,cty) =
+  mk_clenv_from_env (Global.env_of_context gls.it.evar_hyps) gls.sigma n (c, cty)
 
-let mk_clenv_rename_from gls (c,t) = 
-  mk_clenv_from gls (c,rename_bound_var (pf_env gls) [] t)
+let mk_clenv_from gls = mk_clenv_from_n gls None
 
 let mk_clenv_rename_from_n gls n (c,t) = 
   mk_clenv_from_n gls n (c,rename_bound_var (pf_env gls) [] t)
@@ -156,15 +161,17 @@ let mentions clenv mv0 =
   let rec menrec mv1 =
     mv0 = mv1 ||
     let mlist =
-      try (meta_fvalue clenv.env mv1).freemetas
-      with Anomaly _ | Not_found -> Metaset.empty in
+      try match meta_opt_fvalue clenv.evd mv1 with
+      | Some (b,_) -> b.freemetas
+      | None -> Metaset.empty
+      with Not_found -> Metaset.empty in
     meta_exists menrec mlist
   in menrec
 
-let clenv_defined clenv mv = meta_defined clenv.env mv
+let clenv_defined clenv mv = meta_defined clenv.evd mv
 
 let error_incompatible_inst clenv mv  =
-  let na = meta_name clenv.env mv in
+  let na = meta_name clenv.evd mv in
   match na with
       Name id ->
         errorlabstrm "clenv_assign"
@@ -179,17 +186,19 @@ let clenv_assign mv rhs clenv =
   if meta_exists (mentions clenv mv) rhs_fls.freemetas then
     error "clenv_assign: circularity in unification";
   try
-    if meta_defined clenv.env mv then
-      if not (eq_constr (meta_fvalue clenv.env mv).rebus rhs) then
+    if meta_defined clenv.evd mv then
+      if not (eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then
         error_incompatible_inst clenv mv
       else
 	clenv
-    else {clenv with env = meta_assign mv rhs_fls.rebus clenv.env}
+    else 
+      let st = (ConvUpToEta 0,TypeNotProcessed) in
+      {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd}
   with Not_found -> 
     error "clenv_assign: undefined meta"
 
 
-let clenv_wtactic f clenv = {clenv with env = f clenv.env }
+let clenv_wtactic f clenv = {clenv with evd = f clenv.evd }
 
 
 (* [clenv_dependent hyps_only clenv]
@@ -200,74 +209,108 @@ let clenv_wtactic f clenv = {clenv with env = f clenv.env }
  * type of clenv.
  * If [hyps_only] then metavariables occurring in the type are _excluded_ *)
 
-(* collects all metavar occurences, in left-to-right order, preserving
- * repetitions and all. *)
-
-let collect_metas c = 
-  let rec collrec acc c =
-    match kind_of_term c with
-      | Meta mv -> mv::acc
-      | _         -> fold_constr collrec acc c
-  in
-  List.rev (collrec [] c)
-
 (* [clenv_metavars clenv mv]
  * returns a list of the metavars which appear in the type of
  * the metavar mv.  The list is unordered. *)
 
-let clenv_metavars clenv mv = (meta_ftype clenv mv).freemetas
+let clenv_metavars evd mv =
+  (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas
 
 let dependent_metas clenv mvs conclmetas =
   List.fold_right
     (fun mv deps ->
-       Metaset.union deps (clenv_metavars clenv.env mv))
+       Metaset.union deps (clenv_metavars clenv.evd mv))
     mvs conclmetas
 
+let duplicated_metas c = 
+  let rec collrec (one,more as acc) c =
+    match kind_of_term c with
+    | Meta mv -> if List.mem mv one then (one,mv::more) else (mv::one,more)
+    | _       -> fold_constr collrec acc c
+  in
+  snd (collrec ([],[]) c)
+
 let clenv_dependent hyps_only clenv =
-  let mvs = collect_metas (clenv_value clenv) in
+  let mvs = undefined_metas clenv.evd in
   let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
   let deps = dependent_metas clenv mvs ctyp_mvs in
+  let nonlinear = duplicated_metas (clenv_value clenv) in
+  (* Make the assumption that duplicated metas have internal dependencies *)
   List.filter
-    (fun mv -> Metaset.mem mv deps &&
-               not (hyps_only && Metaset.mem mv ctyp_mvs))
+    (fun mv -> (Metaset.mem mv deps &&
+                not (hyps_only && Metaset.mem mv ctyp_mvs))
+               or List.mem mv nonlinear) 
     mvs
 
 let clenv_missing ce = clenv_dependent true ce
 
 (******************************************************************)
 
-let clenv_unify allow_K cv_pb t1 t2 clenv =
-  { clenv with env = w_unify allow_K clenv.templenv cv_pb t1 t2 clenv.env }
+let clenv_unify allow_K ?(flags=default_unify_flags) cv_pb t1 t2 clenv =
+  { clenv with
+      evd = w_unify allow_K ~flags:flags clenv.env cv_pb t1 t2 clenv.evd }
 
-let clenv_unique_resolver allow_K clause gl =
-  clenv_unify allow_K CUMUL (clenv_type clause) (pf_concl gl) clause 
+let clenv_unify_meta_types ?(flags=default_unify_flags) clenv =
+  { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd }
 
+let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl =
+  if isMeta (fst (whd_stack clenv.templtyp.rebus)) then
+    clenv_unify allow_K CUMUL ~flags:flags (clenv_type clenv) (pf_concl gl)
+      (clenv_unify_meta_types ~flags:flags clenv)
+  else
+    clenv_unify allow_K CUMUL ~flags:flags
+      (meta_reducible_instance clenv.evd clenv.templtyp) (pf_concl gl) clenv
 
-(* [clenv_pose_dependent_evars clenv]
+(* [clenv_pose_metas_as_evars clenv dep_mvs]
  * For each dependent evar in the clause-env which does not have a value,
  * pose a value for it by constructing a fresh evar.  We do this in
  * left-to-right order, so that every evar's type is always closed w.r.t.
- * metas. *)
-let clenv_pose_dependent_evars clenv =
-  let dep_mvs = clenv_dependent false clenv in
-  List.fold_left
-    (fun clenv mv ->
-      let ty = clenv_meta_type clenv mv in
-      let (evd,evar) = new_evar clenv.env (cl_env clenv) ty in
-      clenv_assign mv evar {clenv with env=evd})
-    clenv
-    dep_mvs
+ * metas. 
+
+ * Node added 14/4/08 [HH]: before this date, evars were collected in
+   clenv_dependent by collect_metas in the fold_constr order which is
+   (almost) the left-to-right order of dependencies in term. However,
+   due to K-redexes, collect_metas was sometimes missing some metas.
+   The call to collect_metas has been replaced by a call to
+   undefined_metas, but then the order was the one of definition of
+   the metas (numbers in increasing order) which is _not_ the
+   dependency order when a clenv_fchain occurs (because clenv_fchain
+   plugs a term with a list of consecutive metas in place of a - a priori -
+   arbitrary metavariable belonging to another sequence of consecutive metas:
+   e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of 
+   (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2).
+   To ensure the dependency order, we check that the type of each meta
+   to pose is already meta-free, otherwise we postpone the transformation,
+   hoping that no cycle may happen.
+
+   Another approach could have been to use decimal numbers for metas so that
+   in the example above, (H ?1 ?2) would have been renumbered (H ?6.1 ?6.2)
+   then making the numeric order match the dependency order.
+*)
 
-let evar_clenv_unique_resolver clenv gls =
-  clenv_pose_dependent_evars (clenv_unique_resolver false clenv gls)
+let clenv_pose_metas_as_evars clenv dep_mvs =
+  let rec fold clenv = function
+  | [] -> clenv
+  | mv::mvs -> 
+      let ty = clenv_meta_type clenv mv in
+      (* Postpone the evar-ization if dependent on another meta *)
+      (* This assumes no cycle in the dependencies - is it correct ? *)
+      if occur_meta ty then fold clenv (mvs@[mv])
+      else
+	let (evd,evar) = 
+	  new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in
+	let clenv = clenv_assign mv evar {clenv with evd=evd} in
+	fold clenv mvs in
+  fold clenv dep_mvs
 
+let evar_clenv_unique_resolver = clenv_unique_resolver
 
 (******************************************************************)
 
 let connect_clenv gls clenv =
   { clenv with
-    env = evars_reset_evd gls.sigma clenv.env;
-    templenv = Global.env_of_context gls.it.evar_hyps }
+    evd = evars_reset_evd gls.sigma clenv.evd;
+    env = Global.env_of_context gls.it.evar_hyps }
 
 (* [clenv_fchain mv clenv clenv']
  *
@@ -292,29 +335,30 @@ let connect_clenv gls clenv =
 
    In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma].
 *)
-let clenv_fchain mv clenv nextclenv =
+let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv =
   (* Add the metavars of [nextclenv] to [clenv], with their name-environment *)
   let clenv' =
     { templval = clenv.templval;
       templtyp = clenv.templtyp;
-      env = meta_merge clenv.env nextclenv.env;
-      templenv = nextclenv.templenv } in
+      evd = 
+        evar_merge (meta_merge clenv.evd nextclenv.evd) (evars_of clenv.evd);
+      env = nextclenv.env } in
   (* unify the type of the template of [nextclenv] with the type of [mv] *)
   let clenv'' =
-    clenv_unify true CUMUL
-      (clenv_nf_meta clenv' nextclenv.templtyp.rebus)
+    clenv_unify allow_K ~flags:flags CUMUL
+      (clenv_term clenv' nextclenv.templtyp)
       (clenv_meta_type clenv' mv)
       clenv' in
   (* assign the metavar *)
   let clenv''' =
-    clenv_assign mv (clenv_nf_meta clenv' nextclenv.templval.rebus) clenv''
+    clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv''
   in 
   clenv'''
 
 (***************************************************************)
 (* Bindings *)
 
-type arg_bindings = (int * constr) list
+type arg_bindings = open_constr explicit_bindings
 
 (* [clenv_independent clenv]
  * returns a list of metavariables which appear in the term cval,
@@ -328,119 +372,87 @@ let clenv_independent clenv =
   let deps = dependent_metas clenv mvs ctyp_mvs in
   List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
 
-let meta_of_binder clause loc b t mvs =
-  match b with
-    | NamedHyp s ->
-	if List.exists (fun (_,b',_) -> b=b') t then 
-	  errorlabstrm "clenv_match_args" 
-	    (str "The variable " ++ pr_id s ++ 
-	     str " occurs more than once in binding");
-        meta_with_name clause.env s
-    | AnonHyp n ->
-	if List.exists (fun (_,b',_) -> b=b') t then
-	  errorlabstrm "clenv_match_args"
-	    (str "The position " ++ int n ++
-	    str " occurs more than once in binding");
-	try List.nth mvs (n-1)
-	with (Failure _|Invalid_argument _) ->
-          errorlabstrm "clenv_match_args" (str "No such binder")
+let check_bindings bl =
+  match list_duplicates (List.map pi2 bl) with
+    | NamedHyp s :: _ -> 
+	errorlabstrm ""
+	  (str "The variable " ++ pr_id s ++ 
+	   str " occurs more than once in binding list");
+    | AnonHyp n :: _ ->
+	errorlabstrm ""
+	  (str "The position " ++ int n ++
+	   str " occurs more than once in binding list")
+    | [] -> ()
+
+let meta_of_binder clause loc mvs = function
+  | NamedHyp s -> meta_with_name clause.evd s
+  | AnonHyp n ->
+      try List.nth mvs (n-1)
+      with (Failure _|Invalid_argument _) ->
+        errorlabstrm "" (str "No such binder")
 
 let error_already_defined b =
   match b with
-      NamedHyp id ->
-        errorlabstrm "clenv_match_args"
+    | NamedHyp id ->
+        errorlabstrm ""
           (str "Binder name \"" ++ pr_id id ++
            str"\" already defined with incompatible value")
     | AnonHyp n ->
-        anomalylabstrm "clenv_match_args"
+        anomalylabstrm ""
           (str "Position " ++ int n ++ str" already defined")
 
-let clenv_match_args s clause =
-  let mvs = clenv_independent clause in 
-  let rec matchrec clause = function
-    | [] -> clause
-    | (loc,b,c)::t ->
-	let k = meta_of_binder clause loc b t mvs in
-        if meta_defined clause.env k then
-          if eq_constr (meta_fvalue clause.env k).rebus c then
-            matchrec clause t
+let clenv_unify_binding_type clenv c t u =
+  if isMeta (fst (whd_stack u)) then
+    (* Not enough information to know if some subtyping is needed *)
+    CoerceToType, clenv, c
+  else
+    (* Enough information so as to try a coercion now *)
+    try
+      let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
+      TypeProcessed, { clenv with evd = evd }, c
+    with e when precatchable_exception e ->
+      TypeNotProcessed, clenv, c
+
+let clenv_assign_binding clenv k (sigma,c) =
+  let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in
+  let clenv' = { clenv with evd = evar_merge clenv.evd sigma} in
+  let c_typ = nf_betaiota (clenv_get_type_of clenv' c) in
+  let status,clenv'',c = clenv_unify_binding_type clenv' c c_typ k_typ in
+  { clenv'' with evd = meta_assign k (c,(UserGiven,status)) clenv''.evd }
+
+let clenv_match_args bl clenv =
+  if bl = [] then
+    clenv
+  else
+    let mvs = clenv_independent clenv in
+    check_bindings bl;
+    List.fold_left
+      (fun clenv (loc,b,(sigma,c as sc)) ->
+	let k = meta_of_binder clenv loc mvs b in
+        if meta_defined clenv.evd k then
+          if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv
           else error_already_defined b
         else
-	  let k_typ = clenv_hnf_constr clause (clenv_meta_type clause k)
-	    (* nf_betaiota was before in type_of - useful to reduce
-               types like (x:A)([x]P u) *)
-	  and c_typ =
-            clenv_hnf_constr clause
-              (nf_betaiota (clenv_get_type_of clause c)) in
-	  let cl =
-	    (* Try to infer some Meta/Evar from the type of [c] *)
-	    try clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)
-	    with e when precatchable_exception e ->
-	      (* Try to coerce to the type of [k]; cannot merge with the
-	         previous case because Coercion does not handle Meta *)
-              let (_,c') = w_coerce (cl_env clause) c c_typ k_typ clause.env in
-	      try clenv_unify true CONV (mkMeta k) c' clause
-	      with PretypeError (env,CannotUnify (m,n)) ->
-	        Stdpp.raise_with_loc loc
- 	          (PretypeError (env,CannotUnifyBindingType (m,n)))
-	  in matchrec cl t
-  in 
-  matchrec clause s
-
-
-let clenv_constrain_with_bindings bl clause =
-  if bl = [] then 
-    clause 
-  else 
-    let all_mvs = collect_metas clause.templval.rebus in
-    let rec matchrec clause = function
-      | []       -> clause
-      | (n,c)::t ->
-          let k = 
-            (try
-              if n > 0 then 
-		List.nth all_mvs (n-1)
-              else if n < 0 then 
-		List.nth (List.rev all_mvs) (-n-1)
-              else error "clenv_constrain_with_bindings" 
-            with Failure _ ->
-              errorlabstrm "clenv_constrain_with_bindings"
-                (str"Clause did not have " ++ int n ++ str"-th" ++
-                str" absolute argument")) in
-	  let k_typ = nf_betaiota (clenv_meta_type clause k) in
-	  let c_typ = nf_betaiota (clenv_get_type_of clause c) in 
-	  matchrec
-            (clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)) t
-    in 
-    matchrec clause bl
-
-
-(* not exported: maybe useful ? *)
-let clenv_constrain_dep_args hyps_only clause = function
-  | [] -> clause 
-  | mlist ->
-      let occlist = clenv_dependent hyps_only clause in
-      if List.length occlist = List.length mlist then
-	List.fold_left2
-          (fun clenv k c ->
-	    try
-	      let k_typ =
-                clenv_hnf_constr clause (clenv_meta_type clause k) in
-	      let c_typ =
-                clenv_hnf_constr clause (clenv_get_type_of clause c) in
-              (* faire quelque chose avec le sigma retourne ? *)
-	      let (_,c') = w_coerce (cl_env clenv) c c_typ k_typ clenv.env in
-	      clenv_unify true CONV (mkMeta k) c' clenv
-	    with _ ->
-              clenv_unify true CONV (mkMeta k) c clenv)
-          clause occlist mlist
-      else 
-	error ("Not the right number of missing arguments (expected "
-	       ^(string_of_int (List.length occlist))^")")
-
-let clenv_constrain_missing_args mlist clause =
-  clenv_constrain_dep_args true clause mlist
-
+	  clenv_assign_binding clenv k sc)
+      clenv bl
+
+let clenv_constrain_last_binding c clenv =
+  let all_mvs = collect_metas clenv.templval.rebus in
+  let k =
+    try list_last all_mvs 
+    with Failure _ -> error "clenv_constrain_with_bindings" in
+  clenv_assign_binding clenv k (Evd.empty,c)
+
+let clenv_constrain_dep_args hyps_only bl clenv =
+  if bl = [] then
+    clenv
+  else
+    let occlist = clenv_dependent hyps_only clenv in
+    if List.length occlist = List.length bl then
+      List.fold_left2 clenv_assign_binding clenv occlist bl
+    else 
+      error ("Not the right number of missing arguments (expected "
+	     ^(string_of_int (List.length occlist))^")")
 
 (****************************************************************)
 (* Clausal environment for an application *)
@@ -448,7 +460,7 @@ let clenv_constrain_missing_args mlist clause =
 let make_clenv_binding_gen hyps_only n gls (c,t) = function
   | ImplicitBindings largs ->
       let clause = mk_clenv_from_n gls n (c,t) in
-      clenv_constrain_dep_args hyps_only clause largs
+      clenv_constrain_dep_args hyps_only largs clause
   | ExplicitBindings lbind ->
       let clause = mk_clenv_rename_from_n gls n (c,t) in
       clenv_match_args lbind clause
@@ -465,4 +477,4 @@ let pr_clenv clenv =
   h 0
     (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
      str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
-     pr_evar_defs clenv.env)
+     pr_evar_defs clenv.evd)
diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli
index b5433cac..9b2d6e29 100644
--- a/pretyping/clenv.mli
+++ b/pretyping/clenv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: clenv.mli 9277 2006-10-25 13:02:22Z herbelin $ i*)
+(*i $Id: clenv.mli 10856 2008-04-27 16:15:34Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -18,22 +18,21 @@ open Evd
 open Evarutil
 open Mod_subst
 open Rawterm
+open Unification
 (*i*)
 
 (***************************************************************)
 (* The Type of Constructions clausale environments. *)
 
-(* [templenv] is the typing context
- * [env] is the mapping from metavar and evar numbers to their types
+(* [env] is the typing context
+ * [evd] is the mapping from metavar and evar numbers to their types
  *       and values.
  * [templval] is the template which we are trying to fill out.
  * [templtyp] is its type.
- * [namenv] is a mapping from metavar numbers to names, for
- *          use in instantiating metavars by name.
  *)
 type clausenv = {
-  templenv : env;
-  env      : evar_defs;
+  env      : env;
+  evd      : evar_defs;
   templval : constr freelisted;
   templtyp : constr freelisted }
 
@@ -54,48 +53,53 @@ val clenv_meta_type : clausenv -> metavariable -> types
 val mk_clenv_from : evar_info sigma -> constr * types -> clausenv
 val mk_clenv_from_n :
   evar_info sigma -> int option -> constr * types -> clausenv
-val mk_clenv_rename_from : evar_info sigma -> constr * types -> clausenv
-val mk_clenv_rename_from_n :
-  evar_info sigma -> int option -> constr * types -> clausenv
 val mk_clenv_type_of : evar_info sigma -> constr -> clausenv
+val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv
 
 (***************************************************************)
 (* linking of clenvs *)
 
 val connect_clenv : evar_info sigma -> clausenv -> clausenv
-val clenv_fchain : metavariable -> clausenv -> clausenv -> clausenv
+val clenv_fchain : 
+  ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
 
 (***************************************************************)
 (* Unification with clenvs *)
 
 (* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
 val clenv_unify : 
-  bool -> conv_pb -> constr -> constr -> clausenv -> clausenv
+  bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv
 
 (* unifies the concl of the goal with the type of the clenv *)
 val clenv_unique_resolver :
-  bool -> clausenv -> evar_info sigma -> clausenv
+  bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv
 
 (* same as above ([allow_K=false]) but replaces remaining metas
-   with fresh evars *)
+   with fresh evars if [evars_flag] is [true] *)
 val evar_clenv_unique_resolver :
-  clausenv -> evar_info sigma -> clausenv
+  bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv
+
+val clenv_dependent : bool -> clausenv -> metavariable list
+
+val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv
 
 (***************************************************************)
 (* Bindings *)
 
+type arg_bindings = open_constr explicit_bindings
+
 (* bindings where the key is the position in the template of the
    clenv (dependent or not). Positions can be negative meaning to
    start from the rightmost argument of the template. *)
-type arg_bindings = (int * constr) list
-
 val clenv_independent : clausenv -> metavariable list
 val clenv_missing : clausenv -> metavariable list
 
+val clenv_constrain_last_binding : constr -> clausenv -> clausenv
+
 (* defines metas corresponding to the name of the bindings *)
-val clenv_match_args :
-  constr explicit_bindings -> clausenv -> clausenv
-val clenv_constrain_with_bindings : arg_bindings -> clausenv -> clausenv
+val clenv_match_args : arg_bindings -> clausenv -> clausenv
+
+val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv
 
 (* start with a clenv to refine with a given term with bindings *)
 
@@ -103,10 +107,10 @@ val clenv_constrain_with_bindings : arg_bindings -> clausenv -> clausenv
 (* the optional int tells how many prods of the lemma have to be used *)
 (* use all of them if None *)
 val make_clenv_binding_apply :
-  evar_info sigma -> int option -> constr * constr -> constr bindings ->
+  evar_info sigma -> int option -> constr * constr -> open_constr bindings ->
    clausenv
 val make_clenv_binding :
-  evar_info sigma -> constr * constr -> constr bindings -> clausenv
+  evar_info sigma -> constr * constr -> open_constr bindings -> clausenv
 
 (* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
    [lmetas] is a list of metas to be applied to a proof of [t] so that
@@ -125,6 +129,10 @@ val clenv_environments :
 val clenv_environments_evars :
  env -> evar_defs -> int option -> types -> evar_defs * constr list * types
 
+(* [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *)
+val clenv_conv_leq :
+ env -> evar_map -> types -> constr -> int -> constr list
+
 (* if the clause is a product, add an extra meta for this product *)
 exception NotExtensibleClause
 val clenv_push_prod : clausenv -> clausenv
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index cc74b0ad..3c37a49f 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: coercion.ml 9257 2006-10-21 17:28:28Z herbelin $ *)
+(* $Id: coercion.ml 10883 2008-05-05 13:55:24Z herbelin $ *)
 
 open Util
 open Names
@@ -25,38 +25,40 @@ open Termops
 module type S = sig
   (*s Coercions. *)
   
-  (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+  (* [inh_app_fun env evd j] coerces [j] to a function; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a product; it returns [j] if no coercion is applicable *)
   val inh_app_fun :
     env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
     
-  (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+  (* [inh_coerce_to_sort env evd j] coerces [j] to a type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a sort; it fails if no coercion is applicable *)
   val inh_coerce_to_sort : loc ->
     env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
 
-  (* [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
+  (* [inh_coerce_to_base env evd j] coerces [j] to its base type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type its base type (the notion depends on the coercion system) *)
   val inh_coerce_to_base : loc ->
     env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
     
-  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type 
+  (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type 
      [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
      [j.uj_type] are convertible; it fails if no coercion is applicable *)
   val inh_conv_coerce_to : loc -> 
     env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
-    
 
-  (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+  val inh_conv_coerce_rigid_to : loc -> 
+    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+
+  (* [inh_conv_coerces_to loc env evd t t'] checks if an object of type [t]
      is coercible to an object of type [t'] adding evar constraints if needed;
      it fails if no coercion exists *)
   val inh_conv_coerces_to : loc -> 
     env -> evar_defs -> types -> type_constraint_type -> evar_defs
 
-  (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+  (* [inh_pattern_coerce_to loc env evd pat ind1 ind2] coerces the Cases
      pattern [pat] typed in [ind1] into a pattern typed in [ind2];
      raises [Not_found] if no coercion found *)
   val inh_pattern_coerce_to :
@@ -72,8 +74,8 @@ module Default = struct
       | App (f,l) -> mkApp (whd_evar sigma f,l)
       | _ -> whd_evar sigma t
 
-  let class_of1 env isevars t =
-    let sigma = evars_of isevars in
+  let class_of1 env evd t =
+    let sigma = evars_of evd in
     class_of env sigma (whd_app_evar sigma t)
 
   (* Here, funj is a coercion therefore already typed in global context *)
@@ -122,47 +124,51 @@ module Default = struct
              (hj,typ_cl) p)
     with _ -> anomaly "apply_coercion"
 
-  let inh_app_fun env isevars j = 
-    let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+  let inh_app_fun env evd j = 
+    let t = whd_betadeltaiota env (evars_of evd) j.uj_type in
       match kind_of_term t with
-	| Prod (_,_,_) -> (isevars,j)
+	| Prod (_,_,_) -> (evd,j)
 	| Evar ev ->
-	    let (isevars',t) = define_evar_as_arrow isevars ev in
-	      (isevars',{ uj_val = j.uj_val; uj_type = t })
+	    let (evd',t) = define_evar_as_product evd ev in
+	      (evd',{ uj_val = j.uj_val; uj_type = t })
 	| _ ->
        	    (try
- 	       let t,i1 = class_of1 env isevars j.uj_type in
+ 	       let t,i1 = class_of1 env evd j.uj_type in
       	       let p = lookup_path_to_fun_from i1 in
-		 (isevars,apply_coercion env p j t)
-	     with Not_found -> (isevars,j))
+		 (evd,apply_coercion env p j t)
+	     with Not_found -> (evd,j))
 
-  let inh_tosort_force loc env isevars j =
+  let inh_tosort_force loc env evd j =
     try
-      let t,i1 = class_of1 env isevars j.uj_type in
+      let t,i1 = class_of1 env evd j.uj_type in
       let p = lookup_path_to_sort_from i1 in
       let j1 = apply_coercion env p j t in 
-      let j2 = on_judgment_type (whd_evar (evars_of isevars)) j1 in
-        (isevars,type_judgment env j2)
+      let j2 = on_judgment_type (whd_evar (evars_of evd)) j1 in
+        (evd,type_judgment env j2)
     with Not_found ->
-      error_not_a_type_loc loc env (evars_of isevars) j
+      error_not_a_type_loc loc env (evars_of evd) j
 
-  let inh_coerce_to_sort loc env isevars j =
-    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+  let inh_coerce_to_sort loc env evd j =
+    let typ = whd_betadeltaiota env (evars_of evd) j.uj_type in
       match kind_of_term typ with
-	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',s) = define_evar_as_sort isevars ev in
-	      (isevars',{ utj_val = j.uj_val; utj_type = s })
+	| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
+	| Evar ev when not (is_defined_evar evd ev) ->
+	    let (evd',s) = define_evar_as_sort evd ev in
+	      (evd',{ utj_val = j.uj_val; utj_type = s })
 	| _ ->
-	    inh_tosort_force loc env isevars j
+	    inh_tosort_force loc env evd j
 
-  let inh_coerce_to_base loc env isevars j = (isevars, j)
+  let inh_coerce_to_base loc env evd j = (evd, j)
 
-  let inh_coerce_to_fail env isevars c1 v t =
+  let inh_coerce_to_fail env evd rigidonly v t c1 =
+    if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
+    then
+      raise NoCoercion
+    else
     let v', t' =
       try 
-	let t1,i1 = class_of1 env isevars c1 in
-	let t2,i2 = class_of1 env isevars t in
+	let t1,i1 = class_of1 env evd c1 in
+	let t2,i2 = class_of1 env evd t in
 	let p = lookup_path_between (i2,i1) in
 	  match v with
 	      Some v -> 
@@ -171,86 +177,57 @@ module Default = struct
 	    | None -> None, t
       with Not_found -> raise NoCoercion 
     in
-      try (the_conv_x_leq env t' c1 isevars, v', t')
+      try (the_conv_x_leq env t' c1 evd, v')
       with Reduction.NotConvertible -> raise NoCoercion
 
-  let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
-    try (the_conv_x_leq env t c1 isevars, v, t)
+  let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
+    try (the_conv_x_leq env t c1 evd, v)
     with Reduction.NotConvertible ->
-    try inh_coerce_to_fail env isevars c1 v t
+    try inh_coerce_to_fail env evd rigidonly v t c1
     with NoCoercion ->
     match
-      kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
-      kind_of_term (whd_betadeltaiota env (evars_of isevars) c1)
+      kind_of_term (whd_betadeltaiota env (evars_of evd) t),
+      kind_of_term (whd_betadeltaiota env (evars_of evd) c1)
     with
-    | Prod (_,t1,t2), Prod (name,u1,u2) -> 
-	let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in
-	let (evd',b) =
-	  match v' with 
-	  | Some v' ->
-	      (match kind_of_term v' with
-	       | Lambda (x,v1,v2) ->
-		   (* sous-typage non contravariant: pas de "leq v1 u1" *)
-		   (try the_conv_x env v1 u1 isevars, Some (x, v1, v2)
-		   with Reduction.NotConvertible -> (isevars, None))
-	       | _  -> (isevars, None))
-	  | None -> (isevars, None)
-	in
-	(match b with
-	 | Some (x, v1, v2) ->
-	     let env1 = push_rel (x,None,v1) env in
-	     let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
-	       (Some v2) t2 u2 in
-	     (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', 
-	     mkProd (x, v1, t2'))
-	 | None ->
-	     (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
-	     (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
-	     (* has type (name:u1)u2 (with v' recursively obtained) *)
-	     let name = match name with 
-	       | Anonymous -> Name (id_of_string "x")
-	       | _ -> name
-	     in
-	     let env1 = push_rel (name,None,u1) env in
-	     let (evd', v1', t1') =
-	       inh_conv_coerce_to_fail loc env1 isevars
-		 (Some (mkRel 1)) (lift 1 u1) (lift 1 t1)
-	     in
-	     let (evd'', v2', t2') = 
-	       let v2 =
-		 match v with 
-		 | Some v -> option_map (fun x -> mkApp(lift 1 v,[|x|])) v1'
-		 | None -> None
-	       and evd', t2 =
-		 match v1' with 
-		 | Some v1' -> evd', subst_term v1' t2
-		 | None -> 
-		     let evd', ev =
-		       new_evar evd' env ~src:(loc, InternalHole) t1' in
-		     evd', subst_term ev t2
-	       in
-	       inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
-	     in
-	     (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2',
-	     mkProd (name, u1, t2')))
+    | Prod (name,t1,t2), Prod (_,u1,u2) -> 
+        (* Conversion did not work, we may succeed with a coercion. *)
+        (* We eta-expand (hence possibly modifying the original term!) *)
+	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
+	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
+	let name = match name with 
+	  | Anonymous -> Name (id_of_string "x")
+	  | _ -> name in
+	let env1 = push_rel (name,None,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
+        let v1 = Option.get v1 in
+	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
+        let t2 = subst_term v1 t2 in
+	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
+	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
     | _ -> raise NoCoercion
 
   (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-  let inh_conv_coerce_to loc env isevars cj (n, t) =
+  let inh_conv_coerce_to_gen rigidonly loc env evd cj (n, t) =
     match n with
 	None ->
-	  let (evd', val', type') = 
+	  let (evd', val') = 
 	    try 
-	      inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+	      inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
 	    with NoCoercion ->
-	      let sigma = evars_of isevars in
+	      let sigma = evars_of evd in
 		error_actual_type_loc loc env sigma cj t
 	  in
 	  let val' = match val' with Some v -> v | None -> assert(false) in
 	    (evd',{ uj_val = val'; uj_type = t })
-      | Some (init, cur) -> (isevars, cj)
+      | Some (init, cur) -> (evd, cj)
+
+  let inh_conv_coerce_to = inh_conv_coerce_to_gen false
+  let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
+
       
-    let inh_conv_coerces_to loc env (isevars : evar_defs) t (abs, t') = isevars
+    let inh_conv_coerces_to loc env (evd : evar_defs) t (abs, t') = evd
       (* Still problematic, as it changes unification 
       let nabsinit, nabs = 
 	match abs with
@@ -262,7 +239,7 @@ module Default = struct
 	    (* a little more effort to get products is needed *) 
 	    try decompose_prod_n nabs t
 	    with _ -> 
-	      if !Options.debug then
+	      if !Flags.debug then
 		msg_warning (str "decompose_prod_n failed");
 	      raise (Invalid_argument "Coercion.inh_conv_coerces_to")
 	  in
@@ -274,11 +251,11 @@ module Default = struct
 		  env', rng, lift nabs t'
 	      in
 		try 
-		  pi1 (inh_conv_coerce_to_fail loc env' isevars None t t')
+		  pi1 (inh_conv_coerce_to_fail loc env' evd None t t')
 		with NoCoercion ->
-		  isevars) (* Maybe not enough information to unify *)
-	      (*let sigma = evars_of isevars in
+		  evd) (* Maybe not enough information to unify *)
+	      (*let sigma = evars_of evd in
 		error_cannot_coerce env' sigma (t, t'))*)
-	    else isevars
-	with Invalid_argument _ -> isevars	  *)
+	    else evd
+	with Invalid_argument _ -> evd	  *)
 end
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 42ce27fd..b1c8e893 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coercion.mli 8875 2006-05-29 19:59:11Z msozeau $ i*)
+(*i $Id: coercion.mli 10840 2008-04-23 21:29:34Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -45,6 +45,9 @@ module type S = sig
      [j.uj_type] are convertible; it fails if no coercion is applicable *)
   val inh_conv_coerce_to : loc -> 
     env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+
+  val inh_conv_coerce_rigid_to : loc -> 
+    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
     
   (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
      is coercible to an object of type [t'] adding evar constraints if needed;
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 29ec7904..81bb41ef 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: detyping.ml 10135 2007-09-21 14:28:12Z herbelin $ *)
+(* $Id: detyping.ml 11073 2008-06-08 20:24:51Z herbelin $ *)
 
 open Pp
 open Util
@@ -31,8 +31,8 @@ let dl = dummy_loc
 (****************************************************************************)
 (* Tools for printing of Cases                                              *)
 
-let encode_inductive qid =
-  let indsp = global_inductive qid in
+let encode_inductive r =
+  let indsp = inductive_of_reference r in
   let constr_lengths = mis_constr_nargs indsp in
   (indsp,constr_lengths)
 
@@ -108,14 +108,7 @@ module PrintingCasesLet =
 module PrintingIf  = Goptions.MakeRefTable(PrintingCasesIf)
 module PrintingLet = Goptions.MakeRefTable(PrintingCasesLet)
 
-let force_let ci =
-  let indsp = ci.ci_ind in
-  let lc = mis_constr_nargs indsp in PrintingLet.active (indsp,lc)
-let force_if ci =
-  let indsp = ci.ci_ind in
-  let lc = mis_constr_nargs indsp in PrintingIf.active (indsp,lc)
-
-(* Options for printing or not wildcard and synthetisable types *)
+(* Flags.for printing or not wildcard and synthetisable types *)
 
 open Goptions
 
@@ -174,17 +167,18 @@ let computable p k =
   let _,ccl = decompose_lam p in 
   noccur_between 1 (k+1) ccl
 
-
+let avoid_flag isgoal = if isgoal then Some true else None
+ 
 let lookup_name_as_renamed env t s =
   let rec lookup avoid env_names n c = match kind_of_term c with
     | Prod (name,_,c') ->
-	(match concrete_name true avoid env_names name c' with
+	(match concrete_name (Some true) avoid env_names name c' with
            | (Name id,avoid') -> 
 	       if id=s then (Some n) 
 	       else lookup avoid' (add_name (Name id) env_names) (n+1) c'
 	   | (Anonymous,avoid')    -> lookup avoid' env_names (n+1) (pop c'))
     | LetIn (name,_,_,c') ->
-	(match concrete_name true avoid env_names name c' with
+	(match concrete_name (Some true) avoid env_names name c' with
            | (Name id,avoid') -> 
 	       if id=s then (Some n) 
 	       else lookup avoid' (add_name (Name id) env_names) (n+1) c'
@@ -196,15 +190,28 @@ let lookup_name_as_renamed env t s =
 let lookup_index_as_renamed env t n =
   let rec lookup n d c = match kind_of_term c with
     | Prod (name,_,c') ->
-	  (match concrete_name true [] empty_names_context name c' with
+	  (match concrete_name (Some true) [] empty_names_context name c' with
                (Name _,_) -> lookup n (d+1) c'
-             | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c')
+             | (Anonymous,_) -> 
+		 if n=0 then
+		   Some (d-1)
+		 else if n=1 then 
+		   Some d 
+		 else 
+		   lookup (n-1) (d+1) c')
     | LetIn (name,_,_,c') ->
-	  (match concrete_name true [] empty_names_context name c' with
+	  (match concrete_name (Some true) [] empty_names_context name c' with
              | (Name _,_) -> lookup n (d+1) c'
-             | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c')
+             | (Anonymous,_) -> 
+		 if n=0 then 
+		   Some (d-1) 
+		 else if n=1 then 
+		   Some d 
+		 else 
+		   lookup (n-1) (d+1) c'
+	  )
     | Cast (c,_,_) -> lookup n d c
-    | _ -> None
+    | _ -> if n=0 then Some (d-1) else None
   in lookup n 1 t
 
 (**********************************************************************)
@@ -227,7 +234,7 @@ let rec decomp_branch n nal b (avoid,env as e) c =
 	| _ -> 
 	    Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), 
 	    concrete_name in
-    let na',avoid' = f b avoid env na c in
+    let na',avoid' = f (Some b) avoid env na c in
     decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c
 
 let rec build_tree na isgoal e ci cl =
@@ -266,15 +273,15 @@ and contract_branch isgoal e (cn,mkpat,b) =
 
 let is_nondep_branch c n =
   try
-    let _,ccl = decompose_lam_n_assum n c in
-    noccur_between 1 n ccl
+    let sign,ccl = decompose_lam_n_assum n c in
+    noccur_between 1 (rel_context_length sign) ccl
   with _ -> (* Not eta-expanded or not reduced *)
     false
 
 let extract_nondep_branches test c b n =
   let rec strip n r = if n=0 then r else
     match r with
-      | RLambda (_,_,_,t) -> strip (n-1) t
+      | RLambda (_,_,_,_,t) -> strip (n-1) t
       | RLetIn (_,_,_,t) -> strip (n-1) t
       | _ -> assert false in
   if test c n then Some (strip n b) else None
@@ -282,12 +289,14 @@ let extract_nondep_branches test c b n =
 let it_destRLambda_or_LetIn_names n c =
   let rec aux n nal c =
     if n=0 then (List.rev nal,c) else match c with
-      | RLambda (_,na,_,c) -> aux (n-1) (na::nal) c
+      | RLambda (_,na,_,_,c) -> aux (n-1) (na::nal) c
       | RLetIn (_,na,_,c) -> aux (n-1) (na::nal) c
       | _ ->
           (* eta-expansion *)
 	  let rec next l =
 	    let x = Nameops.next_ident_away (id_of_string "x") l in
+	    (* Not efficient but unusual and no function to get free rawvars *)
+(* 	    if occur_rawconstr x c then next (x::l) else x in *)
 	    x
 	  in
 	  let x = next (free_rawvars c) in 
@@ -303,16 +312,16 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
   let synth_type = synthetize_type () in
   let tomatch = detype c in
   let alias, aliastyp, pred= 
-    if (not !Options.raw_print) & synth_type & computable & Array.length bl<>0 
+    if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0 
     then 
       Anonymous, None, None
     else
-      match option_map detype p with
+      match Option.map detype p with
         | None -> Anonymous, None, None
         | Some p ->
             let nl,typ = it_destRLambda_or_LetIn_names k p in
 	    let n,typ = match typ with 
-              | RLambda (_,x,t,c) -> x, c
+              | RLambda (_,x,_,t,c) -> x, c
 	      | _ -> Anonymous, typ in
 	    let aliastyp =
 	      if List.for_all ((=) Anonymous) nl then None
@@ -323,8 +332,10 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
   let eqnl = detype_eqns constructs consnargsl bl in
   let tag =
     try 
-      if !Options.raw_print then
+      if !Flags.raw_print then
         RegularStyle
+      else if st = LetPatternStyle then 
+	st
       else if PrintingLet.active (indsp,consnargsl) then
 	LetStyle
       else if PrintingIf.active (indsp,consnargsl) then 
@@ -344,11 +355,11 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
 	array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
       if array_for_all ((<>) None) nondepbrs then
 	RIf (dl,tomatch,(alias,pred),
-             out_some nondepbrs.(0),out_some nondepbrs.(1))
+             Option.get nondepbrs.(0),Option.get nondepbrs.(1))
       else
-	RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+	RCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
   | _ ->
-      RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+      RCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
 
 let detype_sort = function
   | Prop c -> RProp c
@@ -448,14 +459,14 @@ and share_names isgoal n l avoid env c t =
         let t = detype isgoal avoid env t in
 	let id = next_name_away na avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
-        share_names isgoal (n-1) ((Name id,None,t)::l) avoid env c c'
+        share_names isgoal (n-1) ((Name id,Explicit,None,t)::l) avoid env c c'
     (* May occur for fix built interactively *)
     | LetIn (na,b,t',c), _ when n > 0 ->
         let t' = detype isgoal avoid env t' in
         let b = detype isgoal avoid env b in
 	let id = next_name_away na avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
-        share_names isgoal n ((Name id,Some b,t')::l) avoid env c t
+        share_names isgoal n ((Name id,Explicit,Some b,t')::l) avoid env c t
     (* Only if built with the f/n notation or w/o let-expansion in types *)
     | _, LetIn (_,b,_,t) when n > 0 ->
 	share_names isgoal n l avoid env c (subst1 b t)
@@ -465,7 +476,7 @@ and share_names isgoal n l avoid env c t =
 	let id = next_name_away na' avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
         let appc = mkApp (lift 1 c,[|mkRel 1|]) in
-        share_names isgoal (n-1) ((Name id,None,t')::l) avoid env appc c'
+        share_names isgoal (n-1) ((Name id,Explicit,None,t')::l) avoid env appc c'
     (* If built with the f/n notation: we renounce to share names *)
     | _ ->
         if n>0 then warning "Detyping.detype: cannot factorize fix enough";
@@ -475,7 +486,7 @@ and share_names isgoal n l avoid env c t =
 
 and detype_eqns isgoal avoid env ci computable constructs consnargsl bl =
   try
-    if !Options.raw_print or not (reverse_matching ()) then raise Exit;
+    if !Flags.raw_print or not (reverse_matching ()) then raise Exit;
     let mat = build_tree Anonymous isgoal (avoid,env) ci bl in
     List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c))
       mat
@@ -488,7 +499,7 @@ and detype_eqn isgoal avoid env constr construct_nargs branch =
     if force_wildcard () & noccurn 1 b then
       PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids
     else 
-      let id = next_name_away_with_default "x" x avoid in
+      let id = next_name_away_in_cases_pattern x avoid in
       PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids
   in
   let rec buildrec ids patlist avoid env n b =
@@ -523,15 +534,31 @@ and detype_eqn isgoal avoid env constr construct_nargs branch =
 and detype_binder isgoal bk avoid env na ty c =
   let na',avoid' =
     if bk = BLetIn then
-      concrete_let_name isgoal avoid env na c
+      concrete_let_name (avoid_flag isgoal) avoid env na c
     else
-      concrete_name isgoal avoid env na c in
+      concrete_name (avoid_flag isgoal) avoid env na c in
   let r =  detype isgoal avoid' (add_name na' env) c in
   match bk with
-  | BProd -> RProd (dl, na',detype isgoal avoid env ty, r)
-  | BLambda -> RLambda (dl, na',detype isgoal avoid env ty, r)
+  | BProd -> RProd (dl, na',Explicit,detype isgoal avoid env ty, r)
+  | BLambda -> RLambda (dl, na',Explicit,detype isgoal avoid env ty, r)
   | BLetIn -> RLetIn (dl, na',detype isgoal avoid env ty, r)
 
+let rec detype_rel_context where avoid env 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 ->
+      let na',avoid' =
+	match where with
+	| None -> na,avoid
+	| Some c ->
+	    if b<>None then concrete_let_name None avoid env na c
+	    else concrete_name None avoid env na c in
+      let b = Option.map (detype false avoid env) b in
+      let t = detype false avoid env t in
+      (na',Explicit,b,t) :: aux avoid' (add_name na' env) rest
+  in aux avoid env (List.rev sign)
+
 (**********************************************************************)
 (* Module substitution: relies on detyping                            *)
 
@@ -561,27 +588,27 @@ let rec subst_rawconstr subst raw =
 	if r' == r && rl' == rl then raw else
 	  RApp(loc,r',rl')
 
-  | RLambda (loc,n,r1,r2) -> 
+  | RLambda (loc,n,bk,r1,r2) -> 
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
-	  RLambda (loc,n,r1',r2')
+	  RLambda (loc,n,bk,r1',r2')
 
-  | RProd (loc,n,r1,r2) -> 
+  | RProd (loc,n,bk,r1,r2) -> 
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
-	  RProd (loc,n,r1',r2')
+	  RProd (loc,n,bk,r1',r2')
 
   | RLetIn (loc,n,r1,r2) -> 
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  RLetIn (loc,n,r1',r2')
 
-  | RCases (loc,rtno,rl,branches) -> 
-      let rtno' = option_smartmap (subst_rawconstr subst) rtno
+  | RCases (loc,sty,rtno,rl,branches) -> 
+      let rtno' = Option.smartmap (subst_rawconstr subst) rtno
       and rl' = list_smartmap (fun (a,x as y) ->
         let a' = subst_rawconstr subst a in
         let (n,topt) = x in 
-        let topt' = option_smartmap
+        let topt' = Option.smartmap
           (fun (loc,(sp,i),x,y as t) ->
             let sp' = subst_kn subst sp in
             if sp == sp' then t else (loc,(sp',i),x,y)) topt in
@@ -596,17 +623,17 @@ let rec subst_rawconstr subst raw =
 			branches
       in
 	if rtno' == rtno && rl' == rl && branches' == branches then raw else
-	  RCases (loc,rtno',rl',branches')
+	  RCases (loc,sty,rtno',rl',branches')
 
   | RLetTuple (loc,nal,(na,po),b,c) ->
-      let po' = option_smartmap (subst_rawconstr subst) po
+      let po' = Option.smartmap (subst_rawconstr subst) po
       and b' = subst_rawconstr subst b 
       and c' = subst_rawconstr subst c in
 	if po' == po && b' == b && c' == c then raw else
           RLetTuple (loc,nal,(na,po'),b',c')
-      
+	        
   | RIf (loc,c,(na,po),b1,b2) ->
-      let po' = option_smartmap (subst_rawconstr subst) po
+      let po' = Option.smartmap (subst_rawconstr subst) po
       and b1' = subst_rawconstr subst b1 
       and b2' = subst_rawconstr subst b2 
       and c' = subst_rawconstr subst c in
@@ -617,10 +644,10 @@ let rec subst_rawconstr subst raw =
       let ra1' = array_smartmap (subst_rawconstr subst) ra1
       and ra2' = array_smartmap (subst_rawconstr subst) ra2 in
       let bl' = array_smartmap
-        (list_smartmap (fun (na,obd,ty as dcl) ->
+        (list_smartmap (fun (na,k,obd,ty as dcl) ->
           let ty' = subst_rawconstr subst ty in
-          let obd' = option_smartmap (subst_rawconstr subst) obd in
-          if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
+          let obd' = Option.smartmap (subst_rawconstr subst) obd in
+          if ty'==ty & obd'==obd then dcl else (na,k,obd',ty')))
         bl in
 	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
 	  RRec (loc,fix,ida,bl',ra1',ra2')
@@ -631,8 +658,8 @@ let rec subst_rawconstr subst raw =
       let ref',_ = subst_global subst ref in 
 	if ref' == ref then raw else
 	  RHole (loc,InternalHole)
-  | RHole (loc, (BinderType _ | QuestionMark _ | CasesType |
-      InternalHole | TomatchTypeParameter _)) -> raw
+  | RHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole |
+      TomatchTypeParameter _ | GoalEvar | ImpossibleCase)) -> raw
 
   | RCast (loc,r1,k) -> 
       (match k with 
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 7ac7162f..23090858 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: detyping.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
+(*i $Id: detyping.mli 10410 2007-12-31 13:11:55Z msozeau $ i*)
 
 (*i*)
 open Util
@@ -40,6 +40,9 @@ val detype_case :
 
 val detype_sort : sorts -> rawsort
 
+val detype_rel_context : constr option -> identifier list -> names_context ->
+  rel_context -> rawdecl list
+
 (* look for the index of a named var or a nondep var as it is renamed *)
 val lookup_name_as_renamed  : env -> constr -> identifier -> int option
 val lookup_index_as_renamed : env -> constr -> int -> int option
@@ -47,8 +50,6 @@ val lookup_index_as_renamed : env -> constr -> int -> int option
 val set_detype_anonymous : (loc -> int -> rawconstr) -> unit
 val force_wildcard : unit -> bool
 val synthetize_type : unit -> bool
-val force_if : case_info -> bool
-val force_let : case_info -> bool
 
 (* Utilities to transform kernel cases to simple pattern-matching problem *)
 
@@ -57,4 +58,3 @@ val simple_cases_matrix_of_branches :
   inductive -> int list -> rawconstr list -> cases_clauses
 val return_type_of_predicate :
   inductive -> int -> int -> rawconstr -> predicate_pattern * rawconstr option
-
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 2764633b..58951302 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarconv.ml 9665 2007-02-21 17:08:10Z herbelin $ *)
+(* $Id: evarconv.ml 11157 2008-06-21 10:45:51Z herbelin $ *)
 
 open Pp
 open Util
@@ -43,55 +43,28 @@ let eval_flexible_term env c =
   match kind_of_term c with
   | Const c -> constant_opt_value env c
   | Rel n ->
-      (try let (_,v,_) = lookup_rel n env in option_map (lift n) v
+      (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
       with Not_found -> None)
   | Var id ->
       (try let (_,v,_) = lookup_named id env in v with Not_found -> None)
   | LetIn (_,b,_,c) -> Some (subst1 b c)
   | Lambda _ -> Some c
   | _ -> assert false
-(*
-let rec apprec_nobeta env sigma s =
-  let (t,stack as s) = whd_state s in
-  match kind_of_term (fst s) with
-    | Case (ci,p,d,lf) ->
-        let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
-        let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
-        if reducible_mind_case cr then 
-	  apprec_nobeta env sigma (rslt, stack)
-        else 
-	  s
-    | Fix fix ->
-	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with
-             | Reduced s -> apprec_nobeta env sigma s
-	     | NotReducible -> s)
-    | _ -> s
-
-let evar_apprec_nobeta env isevars stack c =
-  let rec aux s =
-    let (t,stack as s') = apprec_nobeta env (evars_of isevars) s in
-    match kind_of_term t with
-      | Evar (n,_ as ev) when Evd.is_defined (evars_of isevars) n ->
-	  aux (Evd.existential_value (evars_of isevars) ev, stack)
-      | _ -> (t, list_of_stack stack)
-  in aux (c, append_stack (Array.of_list stack) empty_stack)
-*)
 
-let evar_apprec env isevars stack c =
-  let sigma = evars_of isevars in
+let evar_apprec env evd stack c =
+  let sigma = evars_of evd in
   let rec aux s =
-    let (t,stack) = Reductionops.apprec env sigma s in
+    let (t,stack) = whd_betaiota_deltazeta_for_iota_state env sigma s in
     match kind_of_term t with
-      | Evar (n,_ as ev) when Evd.is_defined sigma n ->
+      | Evar (evk,_ as ev) when Evd.is_defined sigma evk ->
 	  aux (Evd.existential_value sigma ev, stack)
       | _ -> (t, list_of_stack stack)
   in aux (c, append_stack_list stack empty_stack)
 
-let apprec_nohdbeta env isevars c =
-  let (t,stack as s) = Reductionops.whd_stack c in
-  match kind_of_term t with
-    | (Case _ | Fix _) -> evar_apprec env isevars [] c
-    | _ -> s
+let apprec_nohdbeta env evd c =
+  match kind_of_term (fst (Reductionops.whd_stack c)) with
+    | (Case _ | Fix _) -> applist (evar_apprec env evd [] c)
+    | _ -> c
 
 (* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem
    (t1 l1) = (t2 l2) into a problem
@@ -116,84 +89,96 @@ let apprec_nohdbeta env isevars c =
 let check_conv_record (t1,l1) (t2,l2) =
   try
     let proji = global_of_constr t1 in
-    let cstr = global_of_constr t2 in
-    let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = 
-      lookup_canonical_conversion (proji, cstr) in
+    let canon_s,l2_effective = 
+      try
+	match kind_of_term t2 with
+	    Prod (_,a,b) -> (* assert (l2=[]); *)
+      	      if dependent (mkRel 1) b then raise Not_found
+	      else lookup_canonical_conversion (proji, Prod_cs),[a;pop b]
+	  | Sort s -> 
+	      lookup_canonical_conversion 
+		(proji, Sort_cs (family_of_sort s)),[]
+	  | _ -> 
+	      let c2 = try global_of_constr t2 with _ -> raise Not_found in
+		lookup_canonical_conversion (proji, Const_cs c2),l2
+      with Not_found -> 
+	lookup_canonical_conversion (proji,Default_cs),[]
+    in
+    let { o_DEF = c; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } 
+	= canon_s in
     let params1, c1, extra_args1 =
       match list_chop (List.length params) l1 with 
 	| params1, c1::extra_args1 -> params1, c1, extra_args1
 	| _ -> assert false in
-    let us2,extra_args2 = list_chop (List.length us) l2 in
-    c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1
+    let us2,extra_args2 = list_chop (List.length us) l2_effective in
+    c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1,
+    (n,applist(t2,l2))
   with _ -> 
     raise Not_found
 
 (* Precondition: one of the terms of the pb is an uninstantiated evar,
  * possibly applied to arguments. *)
 
-let rec ise_try isevars = function
+let rec ise_try evd = function
     [] -> assert false
-  | [f] -> f isevars
+  | [f] -> f evd
   | f1::l ->
-      let (isevars',b) = f1 isevars in
-      if b then (isevars',b) else ise_try isevars l
+      let (evd',b) = f1 evd in
+      if b then (evd',b) else ise_try evd l
 
-let ise_and isevars l =
+let ise_and evd l =
   let rec ise_and i = function
       [] -> assert false
     | [f] -> f i
     | f1::l ->
         let (i',b) = f1 i in
-        if b then  ise_and i' l else (isevars,false) in
-  ise_and isevars l
+        if b then  ise_and i' l else (evd,false) in
+  ise_and evd l
 
-let ise_list2 isevars f l1 l2 =
+let ise_list2 evd f l1 l2 =
   let rec ise_list2 i l1 l2 =
     match l1,l2 with
         [], [] -> (i, true)
       | [x], [y] -> f i x y
       | x::l1, y::l2 ->
           let (i',b) = f i x y in
-          if b then ise_list2 i' l1 l2 else (isevars,false)
-      | _ -> (isevars, false) in
-  ise_list2 isevars l1 l2
+          if b then ise_list2 i' l1 l2 else (evd,false)
+      | _ -> (evd, false) in
+  ise_list2 evd l1 l2
 
-let ise_array2 isevars f v1 v2 =
+let ise_array2 evd f v1 v2 =
   let rec allrec i = function
     | -1 -> (i,true)
     | n ->
         let (i',b) = f i v1.(n) v2.(n) in
-        if b then allrec i' (n-1) else (isevars,false)
+        if b then allrec i' (n-1) else (evd,false)
   in 
   let lv1 = Array.length v1 in
-  if lv1 = Array.length v2 then allrec isevars (pred lv1) 
-  else (isevars,false)
+  if lv1 = Array.length v2 then allrec evd (pred lv1) 
+  else (evd,false)
 
-let rec evar_conv_x env isevars pbty term1 term2 = 
-  let sigma = evars_of isevars in
+let rec evar_conv_x env evd pbty term1 term2 = 
+  let sigma = evars_of evd in
   let term1 = whd_castappevar sigma term1 in
   let term2 = whd_castappevar sigma term2 in
-(*
-  if eq_constr term1 term2 then 
-    true
-  else 
-*)
   (* Maybe convertible but since reducing can erase evars which [evar_apprec]
      could have found, we do it only if the terms are free of evar.
      Note: incomplete heuristic... *)
-  if is_ground_term isevars term1 && is_ground_term isevars term2 &
-     is_fconv pbty env (evars_of isevars) term1 term2 then
-      (isevars,true)
-  else if is_undefined_evar isevars term1 then
-    solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2)
-  else if is_undefined_evar isevars term2 then
-    solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term2,term1)
-  else 
-    let (t1,l1) = apprec_nohdbeta env isevars term1 in
-    let (t2,l2) = apprec_nohdbeta env isevars term2 in
-    evar_eqappr_x env isevars pbty (t1,l1) (t2,l2)
-
-and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
+  if is_ground_term evd term1 && is_ground_term evd term2 &
+     is_fconv pbty env (evars_of evd) term1 term2
+  then
+    (evd,true)
+  else
+  let term1 = apprec_nohdbeta env evd term1 in
+  let term2 = apprec_nohdbeta env evd term2 in
+  if is_undefined_evar evd term1 then
+    solve_simple_eqn evar_conv_x env evd (pbty,destEvar term1,term2)
+  else if is_undefined_evar evd term2 then
+    solve_simple_eqn evar_conv_x env evd (pbty,destEvar term2,term1)
+  else
+    evar_eqappr_x env evd pbty (decompose_app term1) (decompose_app term2)
+
+and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
   (* Evar must be undefined since we have whd_ised *)
   match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with
     | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
@@ -215,25 +200,25 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	and f2 i =
           if sp1 = sp2 then
             ise_and i
-            [(fun i -> ise_array2 i
-                (fun i -> evar_conv_x env i CONV) al1 al2);
-             (fun i -> ise_list2 i
-                 (fun i -> evar_conv_x env i CONV) l1 l2)]
+            [(fun i -> ise_list2 i 
+                  (fun i -> evar_conv_x env i CONV) l1 l2);
+             (fun i -> solve_refl evar_conv_x env i sp1 al1 al2,
+                  true)]
           else (i,false)
 	in 
-	ise_try isevars [f1; f2]
+	ise_try evd [f1; f2]
 
     | Flexible ev1, MaybeFlexible flex2 ->
 	let f1 i =
 	  if 
-	    is_unification_pattern_evar ev1 l1 & 
-	    not (occur_evar (fst ev1) (applist (term2,l2)))
+	    is_unification_pattern_evar env ev1 l1 & 
+	    not (occur_evar (fst ev1) (applist appr2))
 	  then
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t2 = nf_evar (evars_of isevars) (applist(term2,l2)) in
+	    let t2 = nf_evar (evars_of evd) (applist appr2) in
 	    let t2 = solve_pattern_eqn env l1 t2 in
-	    solve_simple_eqn evar_conv_x env isevars (pbty,ev1,t2)
+	    solve_simple_eqn evar_conv_x env evd (pbty,ev1,t2)
 	  else if
             List.length l1 <= List.length l2
 	  then
@@ -253,19 +238,19 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
 	    | None -> (i,false)
 	in 
-	ise_try isevars [f1; f4]
+	ise_try evd [f1; f4]
 
     | MaybeFlexible flex1, Flexible ev2 ->
 	let f1 i =
 	  if 
-	    is_unification_pattern_evar ev2 l2 & 
-	    not (occur_evar (fst ev2) (applist (term1,l1)))
+	    is_unification_pattern_evar env ev2 l2 & 
+	    not (occur_evar (fst ev2) (applist appr1))
 	  then
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t1 = nf_evar (evars_of isevars) (applist(term1,l1)) in
+	    let t1 = nf_evar (evars_of evd) (applist appr1) in
 	    let t1 = solve_pattern_eqn env l2 t1 in
-	    solve_simple_eqn evar_conv_x env isevars (pbty,ev2,t1)
+	    solve_simple_eqn evar_conv_x env evd (pbty,ev2,t1)
 	  else if
        	    List.length l2 <= List.length l1
 	  then
@@ -284,7 +269,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 	    | None -> (i,false)
 	in 
-	ise_try isevars [f1; f4]
+	ise_try evd [f1; f4]
 
     | MaybeFlexible flex1, MaybeFlexible flex2 ->
 	let f2 i =
@@ -313,36 +298,36 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		      evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 		  | None -> (i,false)
 	in 
-	ise_try isevars [f2; f3; f4]
+	ise_try evd [f2; f3; f4]
 
     | Flexible ev1, Rigid _ ->
 	if 
-	  is_unification_pattern_evar ev1 l1 & 
-	  not (occur_evar (fst ev1) (applist (term2,l2)))
+	  is_unification_pattern_evar env ev1 l1 & 
+	  not (occur_evar (fst ev1) (applist appr2))
 	then
 	  (* Miller-Pfenning's patterns unification *)
 	  (* Preserve generality (except that CCI has no eta-conversion) *)
-	  let t2 = nf_evar (evars_of isevars) (applist(term2,l2)) in
+	  let t2 = nf_evar (evars_of evd) (applist appr2) in
 	  let t2 = solve_pattern_eqn env l1 t2 in
-	  solve_simple_eqn evar_conv_x env isevars (pbty,ev1,t2)
+	  solve_simple_eqn evar_conv_x env evd (pbty,ev1,t2)
 	else
 	  (* Postpone the use of an heuristic *)
-	  add_conv_pb (pbty,env,applist(term1,l1),applist(term2,l2)) isevars,
+	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
 	  true
 
     | Rigid _, Flexible ev2 ->
 	if 
-	  is_unification_pattern_evar ev2 l2 & 
-	  not (occur_evar (fst ev2) (applist (term1,l1)))
+	  is_unification_pattern_evar env ev2 l2 & 
+	  not (occur_evar (fst ev2) (applist appr1))
 	then
 	  (* Miller-Pfenning's patterns unification *)
 	  (* Preserve generality (except that CCI has no eta-conversion) *)
-	  let t1 = nf_evar (evars_of isevars) (applist(term1,l1)) in
+	  let t1 = nf_evar (evars_of evd) (applist appr1) in
 	  let t1 = solve_pattern_eqn env l2 t1 in
-	  solve_simple_eqn evar_conv_x env isevars (pbty,ev2,t1)
+	  solve_simple_eqn evar_conv_x env evd (pbty,ev2,t1)
 	else
 	  (* Postpone the use of an heuristic *)
-	  add_conv_pb (pbty,env,applist(term1,l1),applist(term2,l2)) isevars,
+	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
 	  true
 
     | MaybeFlexible flex1, Rigid _ ->
@@ -355,7 +340,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
  		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 	    | None -> (i,false)
 	in 
-	ise_try isevars [f3; f4]
+	ise_try evd [f3; f4]
 	     
     | Rigid _ , MaybeFlexible flex2 -> 
 	let f3 i = 
@@ -367,19 +352,19 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
  		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
 	    | None -> (i,false)
 	in 
-	ise_try isevars [f3; f4]
+	ise_try evd [f3; f4]
 
     | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with
 	  
-	| Cast (c1,_,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2
+	| Cast (c1,_,_), _ -> evar_eqappr_x env evd pbty (c1,l1) appr2
 
-	| _, Cast (c2,_,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
+	| _, Cast (c2,_,_) -> evar_eqappr_x env evd pbty appr1 (c2,l2)
 
 	| Sort s1, Sort s2 when l1=[] & l2=[] ->
-            (isevars,base_sort_cmp pbty s1 s2)
+            (evd,base_sort_cmp pbty s1 s2)
 
 	| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> 
-            ise_and isevars
+            ise_and evd
               [(fun i -> evar_conv_x env i CONV c1 c2);
                (fun i ->
                  let c = nf_evar (evars_of i) c1 in
@@ -400,18 +385,18 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
               and appr2 = evar_apprec env i l2 (subst1 b2 c'2)
 	      in evar_eqappr_x env i pbty appr1 appr2
 	    in 
-	    ise_try isevars [f1; f2]
+	    ise_try evd [f1; f2]
 
 	| LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *)
-	     let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1)
-             in evar_eqappr_x env isevars pbty appr1 appr2
+	     let appr1 = evar_apprec env evd l1 (subst1 b1 c'1)
+             in evar_eqappr_x env evd pbty appr1 appr2
 
 	| _, LetIn (_,b2,_,c'2) ->
-	    let appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
-            in evar_eqappr_x env isevars pbty appr1 appr2
+	    let appr2 = evar_apprec env evd l2 (subst1 b2 c'2)
+            in evar_eqappr_x env evd pbty appr1 appr2
 
 	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> 
-            ise_and isevars
+            ise_and evd
               [(fun i -> evar_conv_x env i CONV c1 c2);
                (fun i ->
  	         let c = nf_evar (evars_of i) c1 in
@@ -419,16 +404,16 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 
 	| Ind sp1, Ind sp2 ->
 	    if sp1=sp2 then
-              ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
-            else (isevars, false)
+              ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
+            else (evd, false)
 
 	| Construct sp1, Construct sp2 ->
 	    if sp1=sp2 then
-              ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
-            else (isevars, false)
+              ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
+            else (evd, false)
 
 	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
-            ise_and isevars
+            ise_and evd
               [(fun i -> evar_conv_x env i CONV p1 p2);
                (fun i -> evar_conv_x env i CONV c1 c2);
 	       (fun i -> ise_array2 i
@@ -437,7 +422,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 
 	| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
             if li1=li2 then
-              ise_and isevars
+              ise_and evd
                 [(fun i -> ise_array2 i
                     (fun i -> evar_conv_x env i CONV) tys1 tys2);
                  (fun i -> ise_array2 i
@@ -445,10 +430,10 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		     bds1 bds2);
 	         (fun i -> ise_list2 i
                      (fun i -> evar_conv_x env i CONV) l1 l2)]
-	    else (isevars,false)
+	    else (evd,false)
 	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
             if i1=i2  then
-              ise_and isevars
+              ise_and evd
                 [(fun i -> ise_array2 i
                     (fun i -> evar_conv_x env i CONV) tys1 tys2);
                  (fun i -> ise_array2 i
@@ -456,30 +441,31 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		     bds1 bds2);
                  (fun i -> ise_list2 i
                      (fun i -> evar_conv_x env i CONV) l1 l2)]
-            else (isevars,false)
+            else (evd,false)
 
-	| (Meta _ | Lambda _), _ -> (isevars,false)
-	| _, (Meta _ | Lambda _) -> (isevars,false)
+	| (Meta _ | Lambda _), _ -> (evd,false)
+	| _, (Meta _ | Lambda _) -> (evd,false)
 
-	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (isevars,false)
-	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (isevars,false)
+	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (evd,false)
+	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (evd,false)
 
 	| (App _ | Case _ | Fix _ | CoFix _), 
-	  (App _ | Case _ | Fix _ | CoFix _) -> (isevars,false)
+	  (App _ | Case _ | Fix _ | CoFix _) -> (evd,false)
 
 	| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
 	| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
 
-and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) = 
-  let (isevars',ks) =
+and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = 
+  let (evd',ks,_) =
     List.fold_left
-      (fun (i,ks) b ->
+      (fun (i,ks,m) b ->
+	 if m=0 then (i,t2::ks, n-1) else
 	 let dloc = (dummy_loc,InternalHole) in
          let (i',ev) = new_evar i env ~src:dloc (substl ks b) in
-	 (i', ev :: ks))
-      (isevars,[]) bs
+	 (i', ev :: ks, n - 1))
+      (evd,[],n) bs
   in
-  ise_and isevars'
+  ise_and evd'
     [(fun i ->
       ise_list2 i
         (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
@@ -491,65 +477,80 @@ and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) =
      (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) ts ts1);
      (fun i -> evar_conv_x env i CONV c1 (applist (c,(List.rev ks))))]
 
-let first_order_unification env isevars pbty (term1,l1) (term2,l2) =
+(* We assume here |l1| <= |l2| *)
+
+let first_order_unification env evd (ev1,l1) (term2,l2) =
+  let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+  ise_and evd
+    (* First compare extra args for better failure message *)
+    [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest2 l1);
+    (fun i ->
+      (* Then instantiate evar unless already done by unifying args *)
+      let t2 = applist(term2,deb2) in
+      if is_defined_evar i ev1 then
+	evar_conv_x env i CONV t2 (mkEvar ev1)
+      else
+	solve_simple_eqn evar_conv_x env i (CONV,ev1,t2))]
+
+let choose_less_dependent_instance evk evd term args =
+  let evi = Evd.find (evars_of evd) evk in
+  let subst = make_pure_subst evi args in
+  let subst' = List.filter (fun (id,c) -> c = term) subst in
+  if subst' = [] then error "Too complex unification problem" else
+  Evd.evar_define evk (mkVar (fst (List.hd subst'))) evd
+
+let apply_conversion_problem_heuristic env evd pbty t1 t2 =
+  let t1 = apprec_nohdbeta env evd (whd_castappevar (evars_of evd) t1) in
+  let t2 = apprec_nohdbeta env evd (whd_castappevar (evars_of evd) t2) in
+  let (term1,l1 as appr1) = decompose_app t1 in
+  let (term2,l2 as appr2) = decompose_app t2 in
   match kind_of_term term1, kind_of_term term2 with
-    | Evar ev1,_ when List.length l1 <= List.length l2 ->
-	let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
-	ise_and isevars
-          (* First compare extra args for better failure message *)
-        [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest2 l1);
-	(fun i ->
-          (* Then instantiate evar unless already done by unifying args *)
-	  let t2 = applist(term2,deb2) in
-	  if is_defined_evar i ev1 then
-	    evar_conv_x env i pbty t2 (mkEvar ev1)
-	  else
-	    solve_simple_eqn evar_conv_x env i (pbty,ev1,t2))]
-    | _,Evar ev2 when List.length l2 <= List.length l1 ->
-	let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-	ise_and isevars
-          (* First compare extra args for better failure message *)
-        [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest1 l2);
-	(fun i ->
-          (* Then instantiate evar unless already done by unifying args *)
-	  let t1 = applist(term1,deb1) in
-	  if is_defined_evar i ev2 then
-	    evar_conv_x env i pbty t1 (mkEvar ev2)
-	  else
-	    solve_simple_eqn evar_conv_x env i (pbty,ev2,t1))]
-    | _ -> 
-	(* Some head evar have been instantiated *)
-	evar_conv_x env isevars pbty (applist(term1,l1)) (applist(term2,l2))
-
-let consider_remaining_unif_problems env isevars =
-  let (isevars,pbs) = get_conv_pbs isevars (fun _ -> true) in
+  | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] ->
+      (* The typical kind of constraint coming from patter-matching return
+         type inference *)
+      assert (array_for_all (fun a -> a = term2 or isEvar a) args1);
+      choose_less_dependent_instance evk1 evd term2 args1, true
+  | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] ->
+      (* The typical kind of constraint coming from patter-matching return
+         type inference *)
+      assert (array_for_all ((=) term1) args2);
+      choose_less_dependent_instance evk2 evd term1 args2, true
+  | Evar ev1,_ when List.length l1 <= List.length l2 ->
+      (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *)
+      first_order_unification env evd (ev1,l1) appr2
+  | _,Evar ev2 when List.length l2 <= List.length l1 ->
+      (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *)
+      first_order_unification env evd (ev2,l2) appr1
+  | _ ->
+      (* Some head evar have been instantiated, or unknown kind of problem *)
+      evar_conv_x env evd pbty t1 t2
+
+let consider_remaining_unif_problems env evd =
+  let (evd,pbs) = extract_all_conv_pbs evd in
   List.fold_left
-    (fun (isevars,b as p) (pbty,env,t1,t2) ->
-      if b then first_order_unification env isevars pbty 
-	(apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t1))
-	(apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t2))
-      else p)
-    (isevars,true)
+    (fun (evd,b as p) (pbty,env,t1,t2) ->
+      if b then apply_conversion_problem_heuristic env evd pbty t1 t2 else p)
+    (evd,true)
     pbs
 
 (* Main entry points *)
 
-let the_conv_x     env t1 t2 isevars =
-  match evar_conv_x env isevars CONV  t1 t2 with
+let the_conv_x     env t1 t2 evd =
+  match evar_conv_x env evd CONV  t1 t2 with
       (evd',true) -> evd'
     | _ -> raise Reduction.NotConvertible
 
-let the_conv_x_leq env t1 t2 isevars =
-  match evar_conv_x env isevars CUMUL t1 t2 with
+let the_conv_x_leq env t1 t2 evd =
+  match evar_conv_x env evd CUMUL t1 t2 with
       (evd', true) -> evd'
     | _ -> raise Reduction.NotConvertible
  
-let e_conv env isevars t1 t2 =
-  match evar_conv_x env !isevars CONV t1 t2 with
-      (evd',true) -> isevars := evd'; true
+let e_conv env evd t1 t2 =
+  match evar_conv_x env !evd CONV t1 t2 with
+      (evd',true) -> evd := evd'; true
     | _ -> false
 
-let e_cumul env isevars t1 t2 =
-  match evar_conv_x env !isevars CUMUL t1 t2 with
-      (evd',true) -> isevars := evd'; true
+let e_cumul env evd t1 t2 =
+  match evar_conv_x env !evd CUMUL t1 t2 with
+      (evd',true) -> evd := evd'; true
     | _ -> false
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 16059d94..fafce268 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarutil.ml 10374 2007-12-13 13:16:52Z notin $ *)
+(* $Id: evarutil.ml 11127 2008-06-14 15:39:46Z herbelin $ *)
 
 open Util
 open Pp
@@ -16,10 +16,12 @@ open Univ
 open Term
 open Termops
 open Sign
+open Pre_env
 open Environ
 open Evd
 open Reductionops
 open Pretype_errors
+open Retyping
 
 (* Expanding existential variables (pretyping.ml) *)
 (* 1- whd_ise fails if an existential is undefined *)
@@ -28,10 +30,10 @@ exception Uninstantiated_evar of existential_key
 
 let rec whd_ise sigma c =
   match kind_of_term c with
-    | Evar (ev,args) when Evd.mem sigma ev ->
-	if Evd.is_defined sigma ev then
-          whd_ise sigma (existential_value sigma (ev,args))
-	else raise (Uninstantiated_evar ev)
+    | Evar (evk,args as ev) when Evd.mem sigma evk ->
+	if Evd.is_defined sigma evk then
+          whd_ise sigma (existential_value sigma ev)
+	else raise (Uninstantiated_evar evk)
   | _ -> c
 
 
@@ -39,8 +41,8 @@ let rec whd_ise sigma c =
 let whd_castappevar_stack sigma c = 
   let rec whrec (c, l as s) =
     match kind_of_term c with
-      | Evar (ev,args) when Evd.mem sigma ev & Evd.is_defined sigma ev -> 
-	  whrec (existential_value sigma (ev,args), l)
+      | Evar (evk,args as ev) when Evd.mem sigma evk & Evd.is_defined sigma evk
+	  -> whrec (existential_value sigma ev, l)
       | Cast (c,_,_) -> whrec (c, l)
       | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
       | _ -> s
@@ -55,6 +57,17 @@ let jl_nf_evar = Pretype_errors.jl_nf_evar
 let jv_nf_evar = Pretype_errors.jv_nf_evar
 let tj_nf_evar = Pretype_errors.tj_nf_evar
 
+let nf_named_context_evar sigma ctx = 
+  Sign.map_named_context (Reductionops.nf_evar sigma) ctx
+
+let nf_rel_context_evar sigma ctx = 
+  Sign.map_rel_context (Reductionops.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 =
   { info with 
     evar_concl = Reductionops.nf_evar evc info.evar_concl;
@@ -63,13 +76,13 @@ let nf_evar_info evc info =
 let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
 		     evm Evd.empty
 
-let nf_evar_defs isevars = Evd.evars_reset_evd (nf_evars (Evd.evars_of isevars)) isevars
+let nf_evar_defs evd = Evd.evars_reset_evd (nf_evars (Evd.evars_of evd)) evd
 
-let nf_isevar isevars = nf_evar (Evd.evars_of isevars)
-let j_nf_isevar isevars = j_nf_evar (Evd.evars_of isevars)
-let jl_nf_isevar isevars = jl_nf_evar (Evd.evars_of isevars)
-let jv_nf_isevar isevars = jv_nf_evar (Evd.evars_of isevars)
-let tj_nf_isevar isevars = tj_nf_evar (Evd.evars_of isevars)
+let nf_isevar evd = nf_evar (Evd.evars_of evd)
+let j_nf_isevar evd = j_nf_evar (Evd.evars_of evd)
+let jl_nf_isevar evd = jl_nf_evar (Evd.evars_of evd)
+let jv_nf_isevar evd = jv_nf_evar (Evd.evars_of evd)
+let tj_nf_isevar evd = tj_nf_evar (Evd.evars_of evd)
 
 (**********************)
 (* Creating new metas *)
@@ -85,8 +98,8 @@ let mk_new_meta () = mkMeta(new_meta())
 let collect_evars emap c =
   let rec collrec acc c =
     match kind_of_term c with
-      | Evar (k,_) ->
-	  if Evd.mem emap k & not (Evd.is_defined emap k) then k::acc
+      | Evar (evk,_) ->
+	  if Evd.mem emap evk & not (Evd.is_defined emap evk) then evk::acc
 	  else (* No recursion on the evar instantiation *) acc
       | _         ->
 	  fold_constr collrec acc c in
@@ -111,7 +124,7 @@ let evars_to_metas sigma (emap, c) =
     mkCast (mkMeta n, DEFAULTcast, ty) in
   let rec replace c =
     match kind_of_term c with
-        Evar (k,_ as ev) when Evd.mem emap' k -> change_exist ev
+      | Evar (evk,_ as ev) when Evd.mem emap' evk -> change_exist ev
       | _ -> map_constr replace c in
   (sigma', replace c)
 
@@ -120,35 +133,11 @@ let evars_to_metas sigma (emap, c) =
 let non_instantiated sigma = 
   let listev = to_list sigma in
   List.fold_left 
-    (fun l (ev,evd) -> 
-       if evd.evar_body = Evar_empty then 
-	 ((ev,nf_evar_info sigma evd)::l) else l)
+    (fun l (ev,evi) -> 
+       if evi.evar_body = Evar_empty then 
+	 ((ev,nf_evar_info sigma evi)::l) else l)
     [] listev
 
-(*************************************)
-(* Metas *)
-
-let meta_value evd mv = 
-  let rec valrec mv =
-    try
-      let b = meta_fvalue evd mv in
-      instance
-        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
-        b.rebus
-    with Anomaly _ | Not_found -> 
-      mkMeta mv
-  in 
-  valrec mv
-
-let meta_instance env b =
-  let c_sigma =
-    List.map 
-      (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
-  in 
-  instance c_sigma b.rebus
-
-let nf_meta env c = meta_instance env (mk_freelisted c)
-
 (**********************)
 (* Creating new evars *)
 (**********************)
@@ -162,63 +151,108 @@ let new_untyped_evar =
  * functional operations on evar sets *
  *------------------------------------*)
 
-(* All ids of sign must be distincts! *)
-let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) instance =
-  let ctxt = named_context_of_val sign in
-    assert (List.length instance = named_context_length ctxt); 
-    if not (list_distinct (ids_of_named_context ctxt)) then 
-      anomaly "new_evar_instance: two vars have the same name";
-    let newev = new_untyped_evar() in
-      (evar_declare sign newev typ ~src:src evd,
-      mkEvar (newev,Array.of_list instance))
-
-let make_evar_instance_with_rel env =
-  let n = rel_context_length (rel_context env) in
-  let vars = 
-    fold_named_context
-      (fun env (id,b,_) l -> (* if b=None then *) mkVar id :: l (*else l*))
-      env ~init:[] in
-  snd (fold_rel_context
-	 (fun env (_,b,_) (i,l) -> 
-	    (i-1, (*if b=None then *) mkRel i :: l (*else l*)))
-	 env ~init:(n,vars))
-
-let make_subst env args =
-  snd (fold_named_context
-    (fun env (id,b,c) (args,l) ->
-       match b, args with
-	 | (* None *) _ , a::rest -> (rest, (id,a)::l)
-(*	 | Some _, _ -> g*)
-	 | _ -> anomaly "Instance does not match its signature")
-    env ~init:(List.rev args,[]))
-
-(* [new_isevar] declares a new existential in an env env with type typ *)
+let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter instance =
+  let instance =
+    match filter with
+    | None -> instance
+    | Some filter -> snd (list_filter2 (fun b c -> b) (filter,instance)) in
+  assert
+    (let ctxt = named_context_of_val sign in
+     list_distinct (ids_of_named_context ctxt));
+  let newevk = new_untyped_evar() in
+  let evd = evar_declare sign newevk typ ~src:src ?filter evd in
+  (evd,mkEvar (newevk,Array.of_list instance))
+
+(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
+ * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
+ * If a variable and an alias of it are bound to the same instance, we skip
+ * the alias (we just use eq_constr -- instead of conv --, since anyway,
+ * only instances that are variables -- or evars -- are later considered;
+ * morever, we can bet that similar instances came at some time from
+ * the very same substitution. The removal of aliased duplicates is
+ * useful to ensure the uniqueness of a projection.
+*)
+
+let make_projectable_subst sigma evi args =
+  let sign = evar_filtered_context evi in
+  let rec alias_of_var id = 
+    match pi2 (Sign.lookup_named id sign) with
+    | Some t when isVar t -> alias_of_var (destVar t)
+    | _ -> id in
+  snd (List.fold_right
+    (fun (id,b,c) (args,l) ->
+      match b,args with
+	| Some c, a::rest when
+	    isVar c & (try eq_constr a (snd (List.assoc (destVar c) l)) with Not_found -> false) -> (rest,l)
+	| _, a::rest -> (rest, (id, (alias_of_var id,whd_evar sigma a))::l)
+	| _ -> anomaly "Instance does not match its signature")
+    sign (List.rev (Array.to_list args),[]))
+
+let make_pure_subst evi args =
+  snd (List.fold_right
+    (fun (id,b,c) (args,l) ->
+      match args with
+	| a::rest -> (rest, (id,a)::l)
+	| _ -> anomaly "Instance does not match its signature")
+    (evar_filtered_context evi) (List.rev (Array.to_list args),[]))
+
+(* [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 x, x=x -> Prop |- f _ (refl_equal x')"
+ *   we want the hole to be instantiated by x', not by x (which would have the
+ *   case in [invert_instance] if x' had disappear of 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 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 inst_vars = List.map mkVar ids in
+  let inst_rels = List.rev (rel_list 0 (nb_rel env)) 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, _, env) =
+    Sign.fold_rel_context
+      (fun (na,c,t) (subst, avoid, env) ->
+	let id = next_name_away na avoid in
+	let d = (id,Option.map (substl subst) c,substl subst t) in
+	(mkVar id :: subst, id::avoid, push_named d env))
+      (rel_context env) ~init:([], ids, env) in
+  (named_context_val env, substl subst typ, inst_rels@inst_vars)
+      
+(* [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 push_rel_context_to_named_context env =
-  let (subst,_,env) =
-  Sign.fold_rel_context
-    (fun (na,c,t) (subst,avoid,env) ->
-       let id = next_name_away na avoid in
-       ((mkVar id)::subst,
-        id::avoid,
-	push_named (id,option_map (substl subst) c,
-                        type_app (substl subst) t)
-	  env))
-    (rel_context env) ~init:([],ids_of_named_context (named_context env),env)
-  in (subst, (named_context_val env))
-
-let new_evar evd env ?(src=(dummy_loc,InternalHole)) typ =
-  let subst,sign = push_rel_context_to_named_context env in
-  let typ' = substl subst typ in
-  let instance = make_evar_instance_with_rel env in
-  new_evar_instance sign evd typ' ~src:src instance
+let new_evar evd env ?(src=(dummy_loc,InternalHole)) ?filter typ =
+  let sign,typ',instance = push_rel_context_to_named_context env typ in
+  new_evar_instance sign evd typ' ~src:src ?filter instance
 
   (* The same using side-effect *)
-let e_new_evar evd env ?(src=(dummy_loc,InternalHole)) ty =
-  let (evd',ev) = new_evar !evd env ~src:src ty in
-    evd := evd';
-    ev
+let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ty =
+  let (evd',ev) = new_evar !evdref env ~src:src ?filter ty in
+  evdref := evd';
+  ev
 
 (*------------------------------------*
  * operations on the evar constraints *
@@ -234,7 +268,7 @@ let is_pattern inst =
 
 let evar_well_typed_body evd ev evi body =
   try
-    let env = evar_env evi in
+    let env = evar_unfiltered_env evi in
     let ty = evi.evar_concl in
     Typing.check env (evars_of evd) body ty;
     true
@@ -246,92 +280,111 @@ let evar_well_typed_body evd ev evi body =
        print_constr body);
     false
 
-let strict_inverse = false
-
-let inverse_instance env isevars ev evi inst rhs =
-  let subst = make_subst (evar_env evi) (Array.to_list inst) in
-  let subst = List.map (fun (x,y) -> (y,mkVar x)) subst in
-  let evd = ref isevars in
-  let error () = 
-    error_not_clean env (evars_of !evd) ev rhs (evar_source ev !evd) in
-  let rec subs rigid k t =
-    match kind_of_term t with
-      | Rel i ->
- 	  if i<=k then t
- 	  else
-            (try List.assoc (mkRel (i-k)) subst
-             with Not_found ->
-               if rigid then error()
-               else if strict_inverse then
-                 failwith "cannot solve pb yet"
-               else t)
-      | Var id ->
-          (try List.assoc t subst
-           with Not_found ->
-             if rigid then error()
-             else if
-               not strict_inverse &&
-               List.exists (fun (id',_,_) -> id=id') (evar_context evi)
-             then
-               failwith "cannot solve pb yet"
-             else t)
-      | Evar (ev,args) ->
-          if Evd.is_defined_evar !evd (ev,args) then
-            subs rigid k (existential_value (evars_of !evd) (ev,args))
-          else
-	    let args' = Array.map (subs false k) args in
-	    mkEvar (ev,args')
-      | _ -> map_constr_with_binders succ (subs rigid) k t in
-  let body = subs true 0 (nf_evar (evars_of isevars) rhs) in
-  (!evd,body)
-
-
-let is_defined_equation env evd (ev,inst) rhs =
-  is_pattern inst &&
-  not (occur_evar ev rhs) &&
-  try
-    let evi = Evd.find (evars_of evd) ev in
-    let (evd',body) = inverse_instance env evd ev evi inst rhs in
-    evar_well_typed_body evd' ev evi body
-  with Failure _ -> false
+(* We have x1..xq |- ?e1 and had to solve something like 
+ * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some 
+ * ?e2[v1..vn], hence flexible. We had to go through k binders and now 
+ * virtually have x1..xq, y1..yk | ?e1' and the equation
+ * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
+ * What we do is to formally introduce ?e1' in context x1..xq, Γ, y1..yk,
+ * but forbidding it to use the variables of Γ (otherwise said,
+ * Γ is here only for ensuring the correct typing of ?e1').
+ *
+ * In fact, we optimize a little and try to compute a maximum
+ * common subpart of x1..xq and Γ. This is done by detecting the
+ * longest subcontext x1..xp such that Γ = x1'..xp' z1..zm and 
+ * u1..up = x1'..xp'.
+ *
+ * At the end, we return ?e1'[x1..xn z1..zm y1..yk] so that ?e1 can be 
+ * instantiated by (...\y1 ... \yk ... ?e1[x1..xn z1..zm y1..yk]) and the
+ * new problem is Σ; Γ, y1..yk |- ?e1'[u1..un z1..zm y1..yk] = c,
+ * making the z1..zm unavailable.
+ *
+ * This is what [extend_evar Γ evd k (?e1[u1..uq]) c] does.
+ *)
 
+let shrink_context env subst ty =
+  let rev_named_sign = List.rev (named_context env) in
+  let rel_sign = rel_context env in
+  (* We merge the contexts (optimization) *)
+  let rec shrink_rel i subst rel_subst rev_rel_sign =
+    match subst,rev_rel_sign with
+    | (id,c)::subst,_::rev_rel_sign when c = mkRel i -> 
+	shrink_rel (i-1) subst (mkVar id::rel_subst) rev_rel_sign
+    | _ ->
+	substl_rel_context rel_subst (List.rev rev_rel_sign), 
+	substl rel_subst ty
+  in
+  let rec shrink_named subst named_subst rev_named_sign =
+    match subst,rev_named_sign with
+    | (id,c)::subst,(id',b',t')::rev_named_sign when c = mkVar id' ->
+	shrink_named subst ((id',mkVar id)::named_subst) rev_named_sign
+    | _::_, [] ->
+	let nrel = List.length rel_sign in
+	let rel_sign, ty = shrink_rel nrel subst [] (List.rev rel_sign) in
+	[], map_rel_context (replace_vars named_subst) rel_sign,
+	replace_vars named_subst ty
+    | _ ->
+	map_named_context (replace_vars named_subst) (List.rev rev_named_sign),
+	rel_sign, ty
+  in
+  shrink_named subst [] rev_named_sign
+
+let extend_evar env evdref k (evk1,args1) c =
+  let ty = get_type_of env (evars_of !evdref) c in
+  let overwrite_first v1 v2 =
+    let v = Array.copy v1 in
+    let n = Array.length v - Array.length v2 in
+    for i = 0 to Array.length v2 - 1 do v.(n+i) <- v2.(i) done;
+    v in
+  let evi1 = Evd.find (evars_of !evdref) evk1 in
+  let named_sign',rel_sign',ty =
+    if k = 0 then [], [], ty
+    else shrink_context env (List.rev (make_pure_subst evi1 args1)) ty in
+  let extenv =
+    List.fold_right push_rel rel_sign'
+      (List.fold_right push_named named_sign' (evar_unfiltered_env evi1)) in
+  let nb_to_hide = rel_context_length rel_sign' - k in
+  let rel_filter = list_map_i (fun i _ -> i > nb_to_hide) 1 rel_sign' in
+  let named_filter1 = List.map (fun _ -> true) (evar_context evi1) in
+  let named_filter2 = List.map (fun _ -> false) named_sign' in
+  let filter = rel_filter@named_filter2@named_filter1 in
+  let evar1' = e_new_evar evdref extenv ~filter:filter ty in
+  let evk1',args1'_in_env = destEvar evar1' in
+  let args1'_in_extenv = Array.map (lift k) (overwrite_first args1'_in_env args1) in
+  (evar1',(evk1',args1'_in_extenv))
+
+let subfilter p filter l =
+  let (filter,_,l) =
+    List.fold_left (fun (filter,l,newl) b ->
+      if b then 
+	let a,l' = match l with a::args -> a,args | _ -> assert false in
+	if p a then (true::filter,l',a::newl) else (false::filter,l',newl)
+      else (false::filter,l,newl))
+      ([],l,[]) filter in
+  (List.rev filter,List.rev l)
+
+let restrict_upon_filter evd evi evk p args =
+  let filter = evar_filter evi in
+  let newfilter,newargs = subfilter p filter args in
+  if newfilter <> filter then
+    let (evd,newev) = new_evar evd (evar_unfiltered_env evi) ~src:(evar_source evk evd)
+	~filter:newfilter evi.evar_concl in
+    let evd = Evd.evar_define evk newev evd in
+    evd,fst (destEvar newev),newargs
+  else
+    evd,evk,args
 
-(* Redefines an evar with a smaller context (i.e. it may depend on less
- * variables) such that c becomes closed.
- * Example: in [x:?1; y:(list ?2)] <?3>x=y /\ x=(nil bool)
- * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
- * ?1 <-- (list ?2)   pb: ?2 may depend on x, but not ?1.
- * What we do is that ?2 is defined by a new evar ?4 whose context will be
- * a prefix of ?2's env, included in ?1's env.
+exception Dependency_error of identifier
 
- Concretely, the assumptions are "env |- ev : T" and "Gamma |-
- ev[hyps:=args]" for some Gamma whose de Bruijn context has length k.
- We create "env' |- ev' : T" for some env' <= env and define ev:=ev'
-*)
+module EvkOrd = 
+struct
+  type t = Term.existential_key
+  let compare = Pervasives.compare
+end
 
-let do_restrict_hyps env k evd ev args =
-  let args = Array.to_list args in
-  let evi = Evd.find (evars_of !evd) ev in
-  let hyps = evar_context evi in
-  let (hyps',ncargs) = list_filter2 (fun _ a -> closedn k a) (hyps,args) in
-    (* No care is taken in case the evar type uses vars filtered out!
-       Assuming that the restriction comes from a well-typed Flex/Flex
-       unification problem (see real_clean), the type of the evar cannot
-       depend on variables that are not in the scope of the other evar,
-       since this other evar has the same type (up to unification).
-     Since moreover, the evar contexts uses names only, the
-       restriction raise no de Bruijn reallocation problem *)
-  let env' =
-    Sign.fold_named_context push_named hyps' ~init:(reset_context env) in
-  let nc = e_new_evar evd env' ~src:(evar_source ev !evd) evi.evar_concl in
-    evd := Evd.evar_define ev nc !evd;
-    let (evn,_) = destEvar nc in
-      mkEvar(evn,Array.of_list ncargs)
-	
+module EvkSet = Set.Make(EvkOrd)
 
-exception Dependency_error of identifier
-	
-let rec check_and_clear_in_constr evd c ids hist =
+let rec check_and_clear_in_constr evdref c ids hist =
   (* returns a new constr where all the evars have been 'cleaned'
      (ie the hypotheses ids have been removed from the contexts of
      evars *)
@@ -341,234 +394,542 @@ let rec check_and_clear_in_constr evd c ids hist =
   in 
     match kind_of_term c with
       | ( Rel _ | Meta _ | Sort _ ) -> c
+
       | ( Const _ | Ind _ | Construct _ ) -> 
 	  let vars = Environ.vars_of_global (Global.env()) c in
 	    List.iter check vars; c
+
       | Var id' ->  
 	  check id'; mkVar id'
-      | Evar (e,l) -> 
-	  if (List.mem e hist) then
+
+      | Evar (evk,l as ev) -> 
+	  if Evd.is_defined_evar !evdref ev then
+	    (* If evk is already defined we replace it by its definition *)
+	    let nc = nf_evar (evars_of !evdref) c in 
+	      (check_and_clear_in_constr evdref nc ids hist)
+	  else if EvkSet.mem evk hist then
+	    (* Loop detection => do nothing *)
 	    c
-	  else
-	    begin
-	      if Evd.is_defined_evar !evd (e,l) then
-		(* If e is already defined we replace it by its definition *)
-		let nc = nf_evar (evars_of !evd) c in 
-		  (check_and_clear_in_constr evd nc ids hist)
-	      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 (evars_of !evd) e in
-		let nconcl = check_and_clear_in_constr evd (evar_concl evi) ids (e::hist) in
-		let (nhyps,nargs) = 
-		  List.fold_right2 
-		    (fun (id,ob,c) i (hy,ar) ->
-		      if List.mem id ids then
-			(hy,ar)
-		      else
-			let d' = (id,
-				 (match ob with 
-				     None -> None
-				   | Some b -> Some (check_and_clear_in_constr evd b ids (e::hist))),
-				 check_and_clear_in_constr evd c ids (e::hist)) in
-			let i' = check_and_clear_in_constr evd i ids (e::hist) in
-			  (d'::hy, i'::ar)
-		    ) 	      
-		    (evar_context evi) (Array.to_list l) ([],[]) in
-		let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
-		let ev'= e_new_evar evd env ~src:(evar_source e !evd) nconcl in
-		  evd := Evd.evar_define e ev' !evd;
-		  let (e',_) = destEvar ev' in
-		    mkEvar(e', Array.of_list nargs)
-	    end
-      | _ -> map_constr (fun c -> check_and_clear_in_constr evd c ids hist) c
-
-and clear_hyps_in_evi evd evi ids =
-  (* clear_evar_hyps erases hypotheses ids in evi, checking if some
+	  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 (evars_of !evdref) evk in
+	    let ctxt = Evd.evar_filtered_context evi in
+	    let (nhyps,nargs,rids) = 
+	      List.fold_right2 
+		(fun (rid,ob,c as h) a (hy,ar,ri) ->
+		  match kind_of_term a with
+		    | Var id -> if List.mem id ids then (hy,ar,id::ri) else (h::hy,a::ar,ri)
+		    | _ -> (h::hy,a::ar,ri)
+		) 	      
+		ctxt (Array.to_list l) ([],[],[]) in
+	    (* nconcl must be computed ids (non instanciated hyps) *)
+	    let nconcl = check_and_clear_in_constr evdref (evar_concl evi) rids (EvkSet.add evk hist) in
+
+	    let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
+	    let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
+	      evdref := Evd.evar_define evk ev' !evdref;
+	      let (evk',_) = destEvar ev' in
+		mkEvar(evk', Array.of_list nargs)
+
+      | _ -> map_constr (fun c -> check_and_clear_in_constr evdref c ids hist) c
+
+let clear_hyps_in_evi evdref hyps concl ids =
+  (* clear_evar_hyps 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 *)
-  let nconcl = try check_and_clear_in_constr evd (evar_concl evi) ids []
+  let nconcl = try check_and_clear_in_constr evdref concl ids EvkSet.empty
     with Dependency_error id' -> error (string_of_id id' ^ " is used in conclusion") in
   let (nhyps,_) = 
-    let aux (id,ob,c) = 
+    let check_context (id,ob,c) = 
       try
 	(id,
 	(match ob with 
 	    None -> None
-	  | Some b -> Some (check_and_clear_in_constr evd b ids [])),
-	check_and_clear_in_constr evd c ids [])
+	  | Some b -> Some (check_and_clear_in_constr evdref b ids EvkSet.empty)),
+	check_and_clear_in_constr evdref c ids EvkSet.empty)
       with Dependency_error id' -> error (string_of_id id' ^ " is used in hypothesis "
-					   ^ string_of_id id)
+					   ^ string_of_id id) 
     in
-      remove_hyps ids aux (evar_hyps evi)
-  in    
-    { evi with
-      evar_concl = nconcl;
-      evar_hyps  = nhyps}
-      
+    let check_value vk =
+      match !vk with
+	| VKnone -> vk
+	| VKvalue (v,d) ->
+	    if (List.for_all (fun e -> not (Idset.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 *)
+	      ref VKnone
+    in
+      remove_hyps ids check_context check_value hyps
+  in
+  (nhyps,nconcl)
+
+(* Expand rels and vars that are bound to other rels or vars so that 
+   dependencies in variables are canonically associated to the most ancient
+   variable in its family of aliased variables *)
+
+let rec expand_var env x = match kind_of_term x with
+  | Rel n ->
+      begin try match pi2 (lookup_rel n env) with
+      | Some t when isRel t -> expand_var env (lift n t)
+      | _ -> x
+      with Not_found -> x
+      end
+  | Var id ->
+      begin match pi2 (lookup_named id env) with
+      | Some t when isVar t -> expand_var env t
+      | _ -> x
+      end
+  | _ -> x
+
+let rec expand_vars_in_term env t = match kind_of_term t with
+  | Rel _ | Var _ -> expand_var env t
+  | _ -> map_constr_with_full_binders push_rel expand_vars_in_term env t
+
+(* [find_projectable_vars env sigma y subst] finds all vars of [subst]
+ * that project on [y]. It is able to find solutions to the following
+ * two kinds of problems:
+ *
+ * - ?n[...;x:=y;...] = y
+ * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable
+ *   
+ * (see test-suite/success/Fixpoint.v for an example of application of
+ * the second kind of problem).
+ *
+ * The seek for [y] is up to variable aliasing.  In case of solutions that
+ * differ only up to aliasing, the binding that requires the less
+ * steps of alias reduction is kept. At the end, only one solution up
+ * to aliasing is kept.
+ *
+ * [find_projectable_vars] also unifies against evars that themselves mention
+ * [y] and recursively.
+ *
+ * In short, the following situations give the following solutions:
+ *
+ * problem                        evar ctxt   soluce remark
+ * z1; z2:=z1 |- ?ev[z1;z2] = z1  y1:A; y2:=y1  y1  \ thanks to defs kept in
+ * z1; z2:=z1 |- ?ev[z1;z2] = z2  y1:A; y2:=y1  y2  / subst and preferring =
+ * z1; z2:=z1 |- ?ev[z1]    = z2  y1:A          y1  thanks to expand_var
+ * z1; z2:=z1 |- ?ev[z2]    = z1  y1:A          y1  thanks to expand_var
+ * z3         |- ?ev[z3;z3] = z3  y1:A; y2:=y1  y2  see make_projectable_subst
+ *
+ * Remark: [find_projectable_vars] assumes that identical instances of
+ * variables in the same set of aliased variables are already removed (see
+ * [make_projectable_subst])
+ *)
 
-let need_restriction k args = not (array_for_all (closedn k) args)
+exception NotUnique
+
+type evar_projection = 
+| ProjectVar 
+| ProjectEvar of existential * evar_info * identifier * evar_projection
+
+let rec find_projectable_vars env sigma y subst =
+  let is_projectable (id,(idc,y')) =
+    let y' = whd_evar sigma y' in
+    if y = y' or expand_var env y = expand_var env y'
+    then (idc,(y'=y,(id,ProjectVar)))
+    else if isEvar y' then
+      let (evk,argsv as t) = destEvar y' in
+      let evi = Evd.find sigma evk in
+      let subst = make_projectable_subst sigma evi argsv in
+      let l = find_projectable_vars env sigma y subst in
+      match l with 
+      | [id',p] -> (idc,(true,(id,ProjectEvar (t,evi,id',p))))
+      | _ -> failwith ""
+    else failwith "" in
+  let l = map_succeed is_projectable subst in
+  let l = list_partition_by (fun (idc,_) (idc',_) -> idc = idc') l in
+  let l = List.map (List.map snd) l in
+  List.map (fun l -> try List.assoc true l with Not_found -> snd (List.hd l)) l
+
+(* [filter_solution] checks if one and only one possible projection exists
+ * among a set of solutions to a projection problem *)
+
+let filter_solution = function
+  | [] -> raise Not_found
+  | (id,p)::_::_ -> raise NotUnique
+  | [id,p] -> (mkVar id, p)
+
+let project_with_effects env sigma effects t subst =
+  let c, p = filter_solution (find_projectable_vars env sigma t subst) in
+  effects := p :: !effects;
+  c
+
+(* In case the solution to a projection problem requires the instantiation of
+ * subsidiary evars, [do_projection_effects] performs them; it
+ * also try to instantiate the type of those subsidiary evars if their
+ * type is an evar too.
+ *
+ * Note: typing creates new evar problems, which induces a recursive dependency
+ * with [evar_define]. To avoid a too large set of recursive functions, we
+ * pass [evar_define] to [do_projection_effects] as a parameter.
+ *)
 
-(* 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 only Miller-Pfenning patterns unification) 
+let rec do_projection_effects define_fun env ty evd = function
+  | ProjectVar -> evd
+  | ProjectEvar ((evk,argsv),evi,id,p) ->
+      let evd = Evd.evar_define evk (mkVar id) evd in
+      (* TODO: simplify constraints involving evk *)
+      let evd = do_projection_effects define_fun env ty evd p in
+      let ty = whd_betadeltaiota env (evars_of evd) (Lazy.force ty) in
+      if not (isSort ty) then
+	(* Don't try to instantiate if a sort because if evar_concl is an
+           evar it may commit to a univ level which is not the right
+           one (however, regarding coercions, because t is obtained by
+           unif, we know that no coercion can be inserted) *)
+	let subst = make_pure_subst evi argsv in
+	let ty' = replace_vars subst evi.evar_concl in
+	let ty' = whd_evar (evars_of evd) ty' in
+	if isEvar ty' then define_fun env (destEvar ty') ty evd else evd
+      else
+	evd
+
+(* Assuming Σ; Γ, y1..yk |- c, [invert_subst Γ k Σ [x1:=u1;...;xn:=un] c]
+ * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. 
+ * The strategy is to imitate the structure of c and then to invert
+ * the variables of c (i.e. rels or vars of Γ) using the algorithm
+ * implemented by project_with_effects/find_projectable_vars.
+ * It returns either a unique solution or says whether 0 or more than
+ * 1 solutions is found.
+ *
+ * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
+ * Postcondition: if φ(x1..xn) is returned then 
+ *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
+ *
+ * The effects correspond to evars instantiated while trying to project.
+ *
+ * [invert_subst] is used on instances of evars. Since the evars are flexible,
+ * these instances are potentially erasable. This is why we don't investigate
+ * whether evars in the instances of evars are unifiable, to the contrary of 
+ * [invert_definition].
+ *)
 
- * 1) Let a unification problem "env |- ev[hyps:=args] = rhs"
- * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
- * where only Rel's and Var's are relevant in subst
- * 3) We recur on rhs, "imitating" the term failing if some Rel/Var not in scope
+type projectibility_kind =
+  | NoUniqueProjection
+  | UniqueProjection of constr * evar_projection list
 
- * Note: we don't assume rhs in normal form, it may fail while it would
- * have succeeded after some reductions
+type projectibility_status =
+  | CannotInvert
+  | Invertible of projectibility_kind
+
+let invert_arg_from_subst env k sigma subst_in_env c_in_env_extended_with_k_binders =
+  let effects = ref [] in
+  let rec aux k t =
+    let t = whd_evar sigma t in
+    match kind_of_term t with
+    | Rel i when i>k ->
+	project_with_effects env sigma effects (mkRel (i-k)) subst_in_env
+    | Var id ->
+	project_with_effects env sigma effects t subst_in_env
+    | _ ->
+	map_constr_with_binders succ aux k t in
+  try 
+    let c = aux k c_in_env_extended_with_k_binders in
+    Invertible (UniqueProjection (c,!effects))
+  with
+    | Not_found -> CannotInvert
+    | NotUnique -> Invertible NoUniqueProjection
+
+let invert_arg env k sigma (evk,args_in_env) c_in_env_extended_with_k_binders =
+  let subst_in_env = make_projectable_subst sigma (Evd.find sigma evk) args_in_env in
+  invert_arg_from_subst env k sigma subst_in_env c_in_env_extended_with_k_binders
+
+let effective_projections =
+  map_succeed (function Invertible c -> c | _ -> failwith"")
+
+let instance_of_projection f env t evd projs =
+  let ty = lazy (Retyping.get_type_of env (evars_of evd) t) in
+  match projs with
+  | NoUniqueProjection -> raise NotUnique
+  | UniqueProjection (c,effects) ->
+      (List.fold_left (do_projection_effects f env ty) evd effects, c)
+
+let filter_of_projection = function CannotInvert -> false | _ -> true
+
+let filter_along f projs v =
+  let l = Array.to_list v in
+  let _,l = list_filter2 (fun b c -> f b) (projs,l) in
+  Array.of_list l
+
+(* Redefines an evar with a smaller context (i.e. it may depend on less
+ * variables) such that c becomes closed.
+ * Example: in "fun (x:?1) (y:list ?2[x]) => x = y :> ?3[x,y] /\ x = nil bool"
+ * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
+ * ?1 <-- list ?2     pb: ?2 may depend on x, but not ?1.
+ * What we do is that ?2 is defined by a new evar ?4 whose context will be
+ * a prefix of ?2's env, included in ?1's env.
+ *
+ * If "hyps |- ?e : T" and "filter" selects a subset hyps' of hyps then
+ * [do_restrict_hyps evd ?e filter] sets ?e:=?e'[hyps'] and returns ?e'
+ * such that "hyps' |- ?e : T"
  *)
-(* Note: error_not_clean should not be an error: it simply means that the
- * conversion test that lead to the faulty call to [real_clean] should return
- * false. The problem is that we won't get the right error message.
+
+let do_restrict_hyps_virtual evd evk filter =
+    (* What to do with dependencies?
+       Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y.
+       - If y is in a non-erasable position in C(x,y) (i.e. it is not below an
+         occurrence of x in the hnf of C), then z should be removed too.
+       - If y is in a non-erasable position in T(x,y,z) then the problem is
+         unsolvable.
+       Computing whether y is erasable or not may be costly and the 
+       interest for this early detection in practice is not obvious. We let
+       it for future work. Anyway, thanks to the use of filters, the whole
+       context remains consistent. *)
+    let evi = Evd.find (evars_of evd) evk in
+    let env = evar_unfiltered_env evi in
+    let oldfilter = evar_filter evi in
+    let filter,_ = List.fold_right (fun oldb (l,filter) ->
+      if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
+      oldfilter ([],List.rev filter) in
+    new_evar evd env ~src:(evar_source evk evd)
+      ~filter:filter evi.evar_concl
+
+let do_restrict_hyps evd evk projs =
+  let filter = List.map filter_of_projection projs in
+  if List.for_all (fun x -> x) filter then
+    evd,evk
+  else
+    let evd,nc = do_restrict_hyps_virtual evd evk filter in
+    let evd = Evd.evar_define evk nc evd in
+    let evk',_ = destEvar nc in
+    evd,evk'
+
+(* [postpone_evar_term] postpones an equation of the form ?e[σ] = c *)
+
+let postpone_evar_term env evd (evk,argsv) rhs =
+  let rhs = expand_vars_in_term env rhs in
+  let evi = Evd.find (evars_of evd) evk in
+  let evd,evk,args =
+    restrict_upon_filter evd evi evk
+      (* Keep only variables that depends in rhs *)
+      (* This is not safe: is the variable is a local def, its body *)
+      (* may contain references to variables that are removed, leading to *)
+      (* a ill-formed context. We would actually need a notion of filter *)
+      (* that says that the body is hidden. Note that expand_vars_in_term *)
+      (* expands only rels and vars aliases, not rels or vars bound to an *)
+      (* arbitrary complex term *)
+      (fun a -> not (isRel a || isVar a) || dependent a rhs)
+      (Array.to_list argsv) in
+  let args = Array.of_list args in
+  let pb = (Reduction.CONV,env,mkEvar(evk,args),rhs) in
+  Evd.add_conv_pb pb evd
+
+(* [postpone_evar_evar] postpones an equation of the form ?e1[σ1] = ?e2[σ2] *)
+
+let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) =
+  (* Leave an equation between (restrictions of) ev1 andv ev2 *)
+  let args1' = filter_along filter_of_projection projs1 args1 in
+  let evd,evk1' = do_restrict_hyps evd evk1 projs1 in
+  let args2' = filter_along filter_of_projection projs2 args2 in
+  let evd,evk2' = do_restrict_hyps evd evk2 projs2 in
+  let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in
+  add_conv_pb pb evd
+
+(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic 
+ * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
+ * - if there are at most one φj for each vj s.t. vj = φj(u1..un), 
+ *   we first restrict ?2 to the subset v_k1..v_kq of the vj that are 
+ *   inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)]
+ * - symmetrically if there are at most one ψj for each uj s.t. 
+ *   uj = ψj(v1..vp), 
+ * - otherwise, each position i s.t. ui does not occur in v1..vp has to
+ *   be restricted and similarly for the vi, and we leave the equation
+ *   as an open equation (performed by [postpone_evar])
+ *
+ * Warning: the notion of unique φj is relative to some given class
+ * of unification problems
+ *
+ * Note: argument f is the function used to instantiate evars.
  *)
 
-exception NotClean of constr
+exception CannotProject of projectibility_status list
 
-let real_clean env isevars ev evi args rhs =
-  let evd = ref isevars in
-  let subst = List.map (fun (x,y) -> (y,mkVar x)) (list_uniquize args) in
-  let rec subs rigid k t =
-    match kind_of_term t with
-      | Rel i ->
- 	 if i<=k then t
- 	 else
-	   (* Flex/Rel problem: unifiable as a pattern iff Rel in ev scope *)
-	   (try List.assoc (mkRel (i-k)) subst 
-	    with Not_found -> if rigid then raise (NotClean t) else t)
-      | Evar (ev,args) ->
-          if Evd.is_defined_evar !evd (ev,args) then
-            subs rigid k (existential_value (evars_of !evd) (ev,args))
-          else
-	    (* Flex/Flex problem: restriction to a common scope *)
-	    let args' = Array.map (subs false k) args in
-	    if need_restriction k args' then
-              do_restrict_hyps (reset_context env) k evd ev args'
-	    else
-	      mkEvar (ev,args')
-      | Var id ->
-	  (* Flex/Var problem: unifiable as a pattern iff Var in scope of ev *)
-          (try List.assoc t subst
-           with Not_found ->
-             if
-               not rigid 
-	     (* I don't understand this line: vars from evar_context evi
-		are private (especially some of them are freshly
-		generated in push_rel_context_to_named_context). They
-		have a priori nothing to do with the vars in env. I
-		remove the test [HH 25/8/06]
-
-		 or List.exists (fun (id',_,_) -> id=id') (evar_context evi)
-	     *)
-             then t
-             else raise (NotClean t))
-               
-      | _ ->
-	  (* Flex/Rigid problem (or assimilated if not normal): we "imitate" *)
-	  map_constr_with_binders succ (subs rigid) k t
-  in
-  let rhs = nf_evar (evars_of isevars) rhs in
-  let rhs = whd_beta rhs (* heuristic *) in
-  let body = 
-    try subs true 0 rhs
-    with NotClean t -> 
-      error_not_clean env (evars_of !evd) ev t (evar_source ev !evd) in
-  (!evd,body)
-
-(* [evar_define] solves the problem lhs = rhs when lhs is an uninstantiated
- * evar, i.e. tries to find the body ?sp for lhs=mkEvar (sp,args)
- * ?sp [ sp.hyps \ args ]  unifies to rhs
- * ?sp must be a closed term, not referring to itself.
- * Not so trivial because some terms of args may be terms that are not
- * variables. In this case, the non-var-or-Rels arguments are replaced
- * by <implicit>. [clean_rhs] will ignore this part of the subtitution. 
- * This leads to incompleteness (we don't deal with pbs that require
- * inference of dependent types), but it seems sensible.
+let solve_evar_evar_l2r f env evd (evk1,args1) (evk2,_ as ev2) =
+  let proj1 = array_map_to_list (invert_arg env 0 (evars_of evd) ev2) args1 in
+  try
+    (* Instantiate ev2 with (a restriction of) ev1 if uniquely projectable *)
+    let proj1' = effective_projections proj1 in
+    let evd,args1' =
+      list_fold_map (instance_of_projection f env (mkEvar ev2)) evd proj1' in
+    let evd,evk1' = do_restrict_hyps evd evk1 proj1 in
+    Evd.evar_define evk2 (mkEvar(evk1',Array.of_list args1')) evd
+  with NotUnique ->
+    raise (CannotProject proj1)
+
+let solve_evar_evar f env evd ev1 ev2 =
+  try solve_evar_evar_l2r f env evd ev1 ev2
+  with CannotProject projs1 ->
+  try solve_evar_evar_l2r f env evd ev2 ev1
+  with CannotProject projs2 ->
+  postpone_evar_evar env evd projs1 ev1 projs2 ev2
+
+let expand_rhs env sigma subst rhs =
+  let d = (named_hd env rhs Anonymous,Some rhs,get_type_of env sigma rhs) in
+  let rhs' = lift 1 rhs in
+  let f (id,(idc,t)) = (id,(idc,replace_term rhs' (mkRel 1) (lift 1 t))) in
+  push_rel d env, List.map f subst, mkRel 1
+
+(* 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) 
  *
- * If after cleaning, some free vars still occur, the function [restrict_hyps]
- * tries to narrow the env of the evars that depend on Rels.
+ * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem
+ * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
+ *    where only Rel's and Var's are relevant in subst
+ * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is 
+ *    not in the scope of ?ev. For instance, the problem
+ *    "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because
+ *    ?1 would be instantiated by y which is not in the scope of ?1.
+ * 4) We try to "project" the term if the process of imitation fails
+ *    and that only one projection is possible
  *
- * If after that free Rels still occur it means that the instantiation
- * cannot be done, as in  [x:?1; y:nat; z:(le y y)] x=z
- * ?1 would be instantiated by (le y y) but y is not in the scope of ?1
+ * Note: we don't assume rhs in normal form, it may fail while it would
+ * have succeeded after some reductions.
+ *
+ * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] 
+ * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
+ * Postcondition: if φ(x1..xn) is returned then 
+ *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
  *)
 
-(* env needed for error messages... *)
-let evar_define env (ev,argsv) rhs isevars =
-  if occur_evar ev rhs
-  then error_occur_check env (evars_of isevars) ev rhs;
-  let args = Array.to_list argsv in 
-  let evi = Evd.find (evars_of isevars) ev in
-  (* the bindings to invert *)
-  let worklist = make_subst (evar_env evi) args in
-  let (isevars',body) = real_clean env isevars ev evi worklist rhs in
-  if occur_meta body then error "Meta cannot occur in evar body"
-  else
+exception NotInvertibleUsingOurAlgorithm of constr
+exception NotEnoughInformationToProgress
+
+let rec invert_definition env evd (evk,argsv as ev) rhs =
+  let evdref = ref evd in
+  let progress = ref false in
+  let evi = Evd.find (evars_of evd) evk in
+  let subst = make_projectable_subst (evars_of evd) evi argsv in
+
+  (* Projection *)
+  let project_variable t =
+    (* Evar/Var problem: unifiable iff variable projectable from ev subst *)
+    try 
+      let sols = find_projectable_vars env (evars_of !evdref) t subst in
+      let c, p = filter_solution sols in
+      let ty = lazy (Retyping.get_type_of env (evars_of !evdref) t) in
+      let evd = do_projection_effects evar_define env ty !evdref p in
+      evdref := evd;
+      c
+    with
+      | Not_found -> raise (NotInvertibleUsingOurAlgorithm t)
+      | NotUnique ->
+	  if not !progress then raise NotEnoughInformationToProgress;
+	  (* No unique projection but still restrict to where it is possible *)
+	  let filter = array_map_to_list (fun c -> isEvar c or c = t) argsv in
+	  let args' = filter_along (fun x -> x) filter argsv in
+	  let evd,evar = do_restrict_hyps_virtual !evdref evk filter in
+	  let evk',_ = destEvar evar in
+	  let pb = (Reduction.CONV,env,mkEvar(evk',args'),t) in
+	  evdref := Evd.add_conv_pb pb evd;
+	  evar in
+
+  let rec imitate (env',k as envk) t =
+    let t = whd_evar (evars_of !evdref) t in
+    match kind_of_term t with
+    | Rel i when i>k -> project_variable (mkRel (i-k))
+    | Var id -> project_variable t
+    | Evar (evk',args' as ev') ->
+        if evk = evk' then error_occur_check env (evars_of evd) evk rhs;
+	(* Evar/Evar problem (but left evar is virtual) *)
+	let projs' =
+	  array_map_to_list
+	    (invert_arg_from_subst env k (evars_of !evdref) subst) args'
+	in
+	(try
+	  (* Try to project (a restriction of) the right evar *)
+	  let eprojs' = effective_projections projs' in
+	  let evd,args' = 
+	    list_fold_map (instance_of_projection evar_define env' t)
+	      !evdref eprojs' in
+	  let evd,evk' = do_restrict_hyps evd evk' projs' in
+	  evdref := evd;
+	  mkEvar (evk',Array.of_list args')
+	with NotUnique ->
+	  assert !progress;
+	  (* Make the virtual left evar real *)
+	  let (evar'',ev'') = extend_evar env' evdref k ev t in
+	  let evd =
+	    (* Try to project (a restriction of) the left evar ... *)
+	    try solve_evar_evar_l2r evar_define env' !evdref ev'' ev'
+	    with CannotProject projs'' ->
+	    (* ... or postpone the problem *)
+	    postpone_evar_evar env' !evdref projs'' ev'' projs' ev' in
+	  evdref := evd;
+	  evar'')
+    | _ ->
+	progress := true;
+	(* 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 rhs (* heuristic *) in
+  let body = imitate (env,0) rhs in
+  (!evdref,body)
+
+(* [evar_define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
+ * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
+ * [evar_define] tries to find an instance lhs such that
+ * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in
+ * context "hyps" and not referring to itself.
+ *)
+
+and evar_define env (evk,_ as ev) rhs evd =
+  try
+    let (evd',body) = invert_definition env evd ev rhs in
+    if occur_meta body then error "Meta cannot occur in evar body";
+    (* invert_definition may have instantiate some evars of rhs with evk *)
+    (* so we recheck acyclicity *)
+    if occur_evar evk body then error_occur_check env (evars_of evd) evk body;
     (* needed only if an inferred type *)
     let body = refresh_universes body in
 (* Cannot strictly type instantiations since the unification algorithm
- * does not unifies applications from left to right.
+ * does not unify applications from left to right.
  * e.g problem f x == g y yields x==y and f==g (in that order) 
  * Another problem is that type variables are evars of type Type
    let _ =
       try
         let env = evar_env evi in
         let ty = evi.evar_concl in
-        Typing.check env (evars_of isevars') body ty
+        Typing.check env (evars_of evd') body ty
       with e ->
         pperrnl
           (str "Ill-typed evar instantiation: " ++ fnl() ++
-           pr_evar_defs isevars' ++ fnl() ++
+           pr_evar_defs evd' ++ fnl() ++
            str "----> " ++ int ev ++ str " := " ++
            print_constr body);
         raise e in*)
-    let isevars'' = Evd.evar_define ev body isevars' in
-    isevars'',[ev]
-
-
+    Evd.evar_define evk body evd'
+  with
+    | NotEnoughInformationToProgress ->
+	postpone_evar_term env evd ev rhs
+    | NotInvertibleUsingOurAlgorithm t -> 
+	error_not_clean env (evars_of evd) evk t (evar_source evk evd)
 
 (*-------------------*)
 (* Auxiliary functions for the conversion algorithms modulo evars
  *)
 
-let has_undefined_evars isevars t = 
-  try let _ = local_strong (whd_ise (evars_of isevars)) t in false
+let has_undefined_evars evd t = 
+  try let _ = local_strong (whd_ise (evars_of evd)) t in false
   with Uninstantiated_evar _ -> true
 
-let is_ground_term isevars t =
-  not (has_undefined_evars isevars t)
-
-let head_is_evar isevars = 
-  let rec hrec k = match kind_of_term k with
-    | Evar n   -> not (Evd.is_defined_evar isevars n)
-    | App (f,_) -> hrec f
-    | Cast (c,_,_) -> hrec c
-    | _ -> false
-  in 
-  hrec 
-
-let rec is_eliminator c = match kind_of_term c with
-  | App _    -> true
-  | Case _ -> true
-  | Cast (c,_,_) -> is_eliminator c
-  | _ -> false
-
-let head_is_embedded_evar isevars c =
-  (head_is_evar isevars c) & (is_eliminator c)
+let is_ground_term evd t =
+  not (has_undefined_evars evd t)
 
 let head_evar = 
   let rec hrec c = match kind_of_term c with
-    | Evar (ev,_)       -> ev
+    | Evar (evk,_)   -> evk
     | Case (_,_,c,_) -> hrec c
-    | App (c,_)        -> hrec c
-    | Cast (c,_,_)        -> hrec c
-    | _                   -> failwith "headconstant"
+    | App (c,_)      -> hrec c
+    | Cast (c,_,_)   -> hrec c
+    | _              -> failwith "headconstant"
   in 
   hrec 
 
@@ -576,20 +937,22 @@ let head_evar =
    that we don't care whether args itself contains Rel's or even Rel's
    distinct from the ones in l *)
 
-let is_unification_pattern_evar (_,args) l =
+let is_unification_pattern_evar env (_,args) l =
   let l' = Array.to_list args @ l in
+  let l' = List.map (expand_var env) l' in
   List.for_all (fun a -> isRel a or isVar a) l' & list_distinct l'
 
-let is_unification_pattern f l =
+let is_unification_pattern env f l =
   match kind_of_term f with
     | Meta _ -> array_for_all isRel l & array_distinct l
-    | Evar ev -> is_unification_pattern_evar ev (Array.to_list l)
+    | Evar ev -> is_unification_pattern_evar env ev (Array.to_list l)
     | _ -> false
 
 (* From a unification problem "?X l1 = term1 l2" such that l1 is made
    of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *)
 
 let solve_pattern_eqn env l1 c =
+  let l1 = List.map (expand_var env) l1 in
   let c' = List.fold_right (fun a c ->
     let c' = subst_term (lift 1 a) (lift 1 c) in
     match kind_of_term a with
@@ -598,6 +961,8 @@ let solve_pattern_eqn env l1 c =
       | Var id -> let (id,_,t) = lookup_named id env in mkNamedLambda id t c'
       | _ -> assert false) 
     l1 c in
+  (* Warning: we may miss some opportunity to eta-reduce more since c'
+     is not in normal form *)
   whd_eta c'
 
 (* This code (i.e. solve_pb, etc.) takes a unification
@@ -637,28 +1002,19 @@ let status_changed lev (pbty,_,t1,t2) =
  * that don't unify are discarded (i.e. ?i is redefined so that it does not
  * depend on these args). *)
 
-let solve_refl conv_algo env isevars ev argsv1 argsv2 =
-  if argsv1 = argsv2 then (isevars,[]) else
-  let evd = Evd.find (evars_of isevars) ev in
-  let hyps = evar_context evd in
-  let (isevars',_,rsign) = 
-    array_fold_left2
-      (fun (isevars,sgn,rsgn) a1 a2 ->
-        let (isevars',b) = conv_algo env isevars Reduction.CONV a1 a2 in
-	 if b then 
-	   (isevars',List.tl sgn, add_named_decl (List.hd sgn) rsgn)
-	 else 
-	   (isevars,List.tl  sgn, rsgn))
-      (isevars,hyps,[]) argsv1 argsv2 
-  in
-  let nsign = List.rev rsign in
-  let (evd',newev) =
-    let env =
-      Sign.fold_named_context push_named nsign ~init:(reset_context env) in
-    new_evar isevars env ~src:(evar_source ev isevars) evd.evar_concl in
-  let evd'' = Evd.evar_define ev newev evd' in
-  evd'', [ev]
-
+let solve_refl conv_algo env evd evk argsv1 argsv2 =
+  if argsv1 = argsv2 then evd else
+  let evi = Evd.find (evars_of evd) evk in
+  (* Filter and restrict if needed *)
+  let evd,evk,args =
+    restrict_upon_filter evd evi evk
+      (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
+      (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
+  (* Leave a unification problem *)
+  let args1,args2 = List.split args in
+  let argsv1 = Array.of_list args1 and argsv2 = Array.of_list args2 in
+  let pb = (Reduction.CONV,env,mkEvar(evk,argsv1),mkEvar(evk,argsv2)) in
+  Evd.add_conv_pb pb evd
 
 (* Tries to solve problem t1 = t2.
  * Precondition: t1 is an uninstantiated evar
@@ -666,45 +1022,57 @@ let solve_refl conv_algo env isevars ev argsv1 argsv2 =
  * if the problem couldn't be solved. *)
 
 (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
-let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) =
+let solve_simple_eqn conv_algo env evd (pbty,(evk1,args1 as ev1),t2) =
   try
-    let t2 = nf_evar (evars_of isevars) t2 in
-    let (isevars,lsp) = match kind_of_term t2 with
-      | Evar (n2,args2 as ev2) ->
-	  if n1 = n2 then
-	    solve_refl conv_algo env isevars n1 args1 args2
+    let t2 = whd_evar (evars_of evd) t2 in
+    let evd = match kind_of_term t2 with
+      | Evar (evk2,args2 as ev2) ->
+	  if evk1 = evk2 then
+	    solve_refl conv_algo env evd evk1 args1 args2
 	  else
-            (try evar_define env ev1 t2 isevars
-            with e when precatchable_exception e ->
-              evar_define env ev2 (mkEvar ev1) isevars)
-(*	    if Array.length args1 < Array.length args2 then
-	      evar_define env ev2 (mkEvar ev1) isevars
-	    else 
-	      evar_define env ev1 t2 isevars*)
+	    if pbty = Reduction.CONV 
+	    then solve_evar_evar evar_define env evd ev1 ev2
+	    else add_conv_pb (pbty,env,mkEvar ev1,t2) evd
       | _ ->
-	  evar_define env ev1 t2 isevars in
-    let (isevars,pbs) = get_conv_pbs isevars (status_changed lsp) in
+	  evar_define env ev1 t2 evd in
+    let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
     List.fold_left
-      (fun (isevars,b as p) (pbty,env,t1,t2) ->
-	if b then conv_algo env isevars pbty t1 t2 else p) (isevars,true)
+      (fun (evd,b as p) (pbty,env,t1,t2) ->
+	if b then conv_algo env evd pbty t1 t2 else p) (evd,true)
       pbs
   with e when precatchable_exception e ->
-    (isevars,false)
+    (evd,false)
 
 
 (* [check_evars] fails if some unresolved evar remains *)
 (* it assumes that the defined existentials have already been substituted *)
 
-let check_evars env initial_sigma isevars c =
-  let sigma = evars_of isevars in
+let check_evars env initial_sigma evd c =
+  let sigma = evars_of evd in
   let c = nf_evar sigma c in
   let rec proc_rec c =
     match kind_of_term c with
-      | Evar (ev,args) ->
-          assert (Evd.mem sigma ev);
-	  if not (Evd.mem initial_sigma ev) then
-            let (loc,k) = evar_source ev isevars in
-	    error_unsolvable_implicit loc env sigma k
+      | Evar (evk,args) ->
+          assert (Evd.mem sigma evk);
+	  if not (Evd.mem initial_sigma evk) then
+            let (loc,k) = evar_source evk evd in
+	    let evi = nf_evar_info sigma (Evd.find sigma evk) in
+	    let explain =
+	      let f (_,_,t1,t2) =
+		(try head_evar t1 = evk with Failure _ -> false)
+		or (try head_evar t2 = evk with Failure _ -> false) in
+	      let check_several c inst =
+		let _,argsv = destEvar c in
+		let l = List.filter (eq_constr inst) (Array.to_list argsv) in
+		let n = List.length l in
+		(* Maybe should we select one instead of failing ... *)
+		if n >= 2 then Some (SeveralInstancesFound n) else None in
+	      match List.filter f (snd (extract_all_conv_pbs evd)) with
+	      | (_,_,t1,t2)::_ ->
+		  if isEvar t2 then check_several t2 t1 
+		  else check_several t1 t2
+	      | [] -> None
+	    in  error_unsolvable_implicit loc env sigma evi k explain
       | _ -> iter_constr proc_rec c
   in proc_rec c
 
@@ -754,14 +1122,15 @@ let mk_valcon c = Some c
    It is, but that's not too bad *)
 let define_evar_as_abstraction abs evd (ev,args) =
   let evi = Evd.find (evars_of evd) ev in
-  let evenv = evar_env evi in
-  let (evd1,dom) = new_evar evd evenv (new_Type()) in
+  let evenv = evar_unfiltered_env evi in
+  let (evd1,dom) = new_evar evd evenv (new_Type()) ~filter:(evar_filter evi) in
   let nvar =
     next_ident_away (id_of_string "x")
       (ids_of_named_context (evar_context evi)) in
   let newenv = push_named (nvar, None, dom) evenv in
   let (evd2,rng) =
-    new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) in
+    new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) 
+      ~filter:(true::evar_filter evi) in
   let prod = abs (Name nvar, dom, subst_var nvar rng) in
   let evd3 = Evd.evar_define ev prod evd2 in
   let evdom = fst (destEvar dom), args in
@@ -770,15 +1139,15 @@ let define_evar_as_abstraction abs evd (ev,args) =
   let prod' = abs (Name nvar, mkEvar evdom, mkEvar evrng) in
   (evd3,prod')
 
-let define_evar_as_arrow evd (ev,args) =
+let define_evar_as_product evd (ev,args) =
   define_evar_as_abstraction (fun t -> mkProd t) evd (ev,args)
 
 let define_evar_as_lambda evd (ev,args) =
   define_evar_as_abstraction (fun t -> mkLambda t) evd (ev,args)
 
-let define_evar_as_sort isevars (ev,args) =
+let define_evar_as_sort evd (ev,args) =
   let s = new_Type () in
-  Evd.evar_define ev s isevars, destSort s
+  Evd.evar_define ev s evd, destSort s
 
 
 (* We don't try to guess in which sort the type should be defined, since
@@ -791,33 +1160,33 @@ let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
    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 isevars tycon = 
+let split_tycon loc env evd tycon = 
   let rec real_split c = 
-    let sigma = evars_of isevars in
+    let sigma = evars_of evd in
     let t = whd_betadeltaiota env sigma c in
       match kind_of_term t with
-	| Prod (na,dom,rng) -> isevars, (na, dom, rng)
-	| Evar ev when not (Evd.is_defined_evar isevars ev) ->
-	    let (isevars',prod) = define_evar_as_arrow isevars ev in
+	| Prod (na,dom,rng) -> evd, (na, dom, rng)
+	| Evar ev when not (Evd.is_defined_evar evd ev) ->
+	    let (evd',prod) = define_evar_as_product evd ev in
 	    let (_,dom,rng) = destProd prod in
-	      isevars',(Anonymous, dom, rng)
+	      evd',(Anonymous, dom, rng)
 	| _ -> error_not_product_loc loc env sigma c
   in
     match tycon with
-      | None -> isevars,(Anonymous,None,None)
+      | None -> evd,(Anonymous,None,None)
       | Some (abs, c) ->
 	  (match abs with
 	       None -> 
-		 let isevars', (n, dom, rng) = real_split c in
-		   isevars', (n, mk_tycon dom, mk_tycon rng)
+		 let evd', (n, dom, rng) = real_split c in
+		   evd', (n, mk_tycon dom, mk_tycon rng)
 	     | Some (init, cur) ->
 		 if cur = 0 then 
-		   let isevars', (x, dom, rng) = real_split c in
-		     isevars, (Anonymous, 
+		   let evd', (x, dom, rng) = real_split c in
+		     evd, (Anonymous, 
 			       Some (Some (init, 0), dom), 
 			       Some (Some (init, 0), rng))
 		 else
-		   isevars, (Anonymous, None, Some (Some (init, pred cur), c)))
+		   evd, (Anonymous, None, Some (Some (init, pred cur), c)))
 
 let valcon_of_tycon x = 
   match x with
@@ -833,7 +1202,7 @@ let lift_abstr_tycon_type n (abs, t) =
 	  else (Some (init, abs'), t)
 
 let lift_tycon_type n (abs, t) = (abs, lift n t)
-let lift_tycon n = option_map (lift_tycon_type n)
+let lift_tycon n = Option.map (lift_tycon_type n)
 
 let pr_tycon_type env (abs, t) =
   match abs with 
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 896bf26c..c915d4b0 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarutil.mli 9573 2007-01-31 20:18:18Z notin $ i*)
+(*i $Id: evarutil.mli 11136 2008-06-18 10:41:34Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -34,10 +34,10 @@ val new_untyped_evar : unit -> existential_key
 (***********************************************************)
 (* Creating a fresh evar given their type and context *)
 val new_evar :
-  evar_defs -> env -> ?src:loc * hole_kind -> types -> evar_defs * constr
+  evar_defs -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> evar_defs * constr
 (* the same with side-effects *)
 val e_new_evar :
-  evar_defs ref -> env -> ?src:loc * hole_kind -> types -> constr
+  evar_defs ref -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> 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
@@ -46,16 +46,18 @@ val e_new_evar :
    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_defs -> types -> ?src:loc * hole_kind ->
-   constr list -> evar_defs * constr
+ named_context_val -> evar_defs -> types -> ?src:loc * hole_kind -> ?filter:bool list -> constr list -> evar_defs * constr
 
-(***********************************************************)
-(* Instanciate evars *)
+val make_pure_subst : evar_info -> constr array -> (identifier * constr) list
 
-(* suspicious env ? *)
-val evar_define :
-  env -> existential -> constr -> evar_defs -> evar_defs * evar list
+(***********************************************************)
+(* Instantiate evars *)
 
+(* [evar_define env ev c] try to instantiate [ev] with [c] (typed in [env]),
+   possibly solving related unification problems, possibly leaving open
+   some problems that cannot be solved in a unique way;
+   failed if the instance is not valid for the given [ev] *)
+val evar_define : env -> existential -> constr -> evar_defs -> evar_defs
 
 (***********************************************************)
 (* Evars/Metas switching... *)
@@ -71,8 +73,10 @@ val non_instantiated : evar_map -> (evar * evar_info) list
 (* Unification utils *)
 
 val is_ground_term :  evar_defs -> constr -> bool
-val is_eliminator : constr -> bool
-val head_is_embedded_evar :  evar_defs -> constr -> bool
+val solve_refl : 
+  (env ->  evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
+  -> env ->  evar_defs -> existential_key -> constr array -> constr array ->
+    evar_defs
 val solve_simple_eqn :
   (env ->  evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
   -> env ->  evar_defs -> conv_pb * existential * constr ->
@@ -82,12 +86,12 @@ val solve_simple_eqn :
    new unresolved evar remains in [c] *)
 val check_evars : env -> evar_map -> evar_defs -> constr -> unit
 
-val define_evar_as_arrow : evar_defs -> existential -> evar_defs * types
+val define_evar_as_product : evar_defs -> existential -> evar_defs * types
 val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types
 val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts
 
-val is_unification_pattern_evar : existential -> constr list -> bool
-val is_unification_pattern : constr -> constr array -> bool
+val is_unification_pattern_evar : env -> existential -> constr list -> bool
+val is_unification_pattern : env -> constr -> constr array -> bool
 val solve_pattern_eqn : env -> constr list -> constr -> constr
 
 (***********************************************************)
@@ -136,6 +140,10 @@ val tj_nf_evar :
 val nf_evar_info : evar_map -> evar_info -> evar_info
 val nf_evars : evar_map -> evar_map
 
+val nf_named_context_evar : evar_map -> named_context -> named_context
+val nf_rel_context_evar : evar_map -> rel_context -> rel_context
+val nf_env_evar : evar_map -> env -> env
+
 (* Same for evar defs *)
 val nf_isevar :  evar_defs -> constr -> constr
 val j_nf_isevar :  evar_defs -> unsafe_judgment -> unsafe_judgment
@@ -153,6 +161,10 @@ exception Uninstantiated_evar of existential_key
 val whd_ise :  evar_map -> constr -> constr
 val whd_castappevar :  evar_map -> constr -> constr
 
+(* Replace the vars and rels that are aliases to other vars and rels by *)
+(* their representative that is most ancient in the context *)
+val expand_vars_in_term : env -> constr -> constr 
+
 (*********************************************************************)
 (* debug pretty-printer: *)
 
@@ -162,4 +174,5 @@ val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
 
 (**********************************)
 (* Removing hyps in evars'context *)
-val clear_hyps_in_evi : evar_defs ref -> evar_info -> identifier list -> evar_info
+val clear_hyps_in_evi : evar_defs ref -> named_context_val -> types ->
+  identifier list -> named_context_val * types
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 69d4352f..76a5ff26 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evd.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: evd.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -31,9 +31,28 @@ type evar_info = {
   evar_concl : constr;
   evar_hyps : named_context_val;
   evar_body : evar_body;
+  evar_filter : bool list;
   evar_extra : Dyn.t option}
 
+let make_evar hyps ccl = {
+  evar_concl = ccl;
+  evar_hyps = hyps;
+  evar_body = Evar_empty;
+  evar_filter = List.map (fun _ -> true) (named_context_of_val hyps);
+  evar_extra = None
+}
+
+let evar_concl evi = evi.evar_concl
+let evar_hyps evi = evi.evar_hyps
 let evar_context evi = named_context_of_val evi.evar_hyps
+let evar_body evi = evi.evar_body
+let evar_filter evi = evi.evar_filter
+let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps
+let evar_filtered_context evi = 
+  snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi))
+let evar_env evi = 
+  List.fold_right push_named (evar_filtered_context evi)
+    (reset_context (Global.env()))
 
 let eq_evar_info ei1 ei2 =
   ei1 == ei2 || 
@@ -49,42 +68,37 @@ let empty = Evarmap.empty
 
 let to_list evc = (* Workaround for change in Map.fold behavior *)
   let l = ref [] in 
-    Evarmap.iter (fun ev x -> l:=(ev,x)::!l) evc;
-    !l
+  Evarmap.iter (fun evk x -> l := (evk,x)::!l) evc;
+  !l
 
-let dom evc = Evarmap.fold (fun ev _ acc -> ev::acc) evc []
+let dom evc = Evarmap.fold (fun evk _ acc -> evk::acc) evc []
 let find evc k = Evarmap.find k evc
 let remove evc k = Evarmap.remove k evc
 let mem evc k = Evarmap.mem k evc
 let fold = Evarmap.fold
 
-let add evd ev newinfo =  Evarmap.add ev newinfo evd
+let add evd evk newinfo =  Evarmap.add evk newinfo evd
 
-let define evd ev body = 
+let define evd evk body = 
   let oldinfo =
-    try find evd ev
+    try find evd evk
     with Not_found -> error "Evd.define: cannot define undeclared evar" in
   let newinfo =
     { oldinfo with
       evar_body = Evar_defined body } in
   match oldinfo.evar_body with
-    | Evar_empty -> Evarmap.add ev newinfo evd
-    | _ -> anomaly "Evd.define: cannot define an isevar twice"
-    
-let is_evar sigma ev = mem sigma ev
+    | Evar_empty -> Evarmap.add evk newinfo evd
+    | _ -> anomaly "Evd.define: cannot define an evar twice"
 
-let is_defined sigma ev =
-  let info = find sigma ev in 
-  not (info.evar_body = Evar_empty)
+let is_evar sigma evk = mem sigma evk
 
-let evar_concl ev = ev.evar_concl
-let evar_hyps ev = ev.evar_hyps
-let evar_body ev = ev.evar_body
-let evar_env evd = Global.env_of_context evd.evar_hyps
+let is_defined sigma evk =
+  let info = find sigma evk in 
+  not (info.evar_body = Evar_empty)
 
-let string_of_existential ev = "?" ^ string_of_int ev
+let string_of_existential evk = "?" ^ string_of_int evk
 
-let existential_of_int ev = ev
+let existential_of_int evk = evk
 
 (*******************************************************************)
 (* Formerly Instantiate module *)
@@ -120,14 +134,14 @@ let existential_type sigma (n,args) =
     try find sigma n
     with Not_found ->
       anomaly ("Evar "^(string_of_existential n)^" was not declared") in
-  let hyps = evar_context info in
+  let hyps = evar_filtered_context info in
   instantiate_evar hyps info.evar_concl (Array.to_list args)
 
 exception NotInstantiatedEvar
 
 let existential_value sigma (n,args) =
   let info = find sigma n in
-  let hyps = evar_context info in
+  let hyps = evar_filtered_context info in
   match evar_body info with
     | Evar_defined c ->
 	instantiate_evar hyps c (Array.to_list args)
@@ -287,6 +301,8 @@ let existential_value (sigma,_) = existential_value sigma
 let existential_type (sigma,_) = existential_type sigma
 let existential_opt_value (sigma,_) = existential_opt_value sigma
 
+let merge e e' = fold (fun n v sigma -> add sigma n v) e' e
+
 (*******************************************************************)
 type open_constr = evar_map * constr
 
@@ -325,16 +341,45 @@ let mk_freelisted c =
 
 let map_fl f cfl = { cfl with rebus=f cfl.rebus }
 
+(* Status of an instance found by unification wrt to the meta it solves:
+  - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
+  - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
+  - a term that can be eta-expanded n times while still being a solution
+    (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
+*)
+
+type instance_constraint =
+    IsSuperType | IsSubType | ConvUpToEta of int | UserGiven
+
+(* Status of the unification of the type of an instance against the type of
+     the meta it instantiates:
+   - CoerceToType means that the unification of types has not been done
+     and that a coercion can still be inserted: the meta should not be
+     substituted freely (this happens for instance given via the
+     "with" binding clause).
+   - TypeProcessed means that the information obtainable from the
+     unification of types has been extracted.
+   - TypeNotProcessed means that the unification of types has not been
+     done but it is known that no coercion may be inserted: the meta
+     can be substituted freely.
+*)
+
+type instance_typing_status =
+    CoerceToType | TypeNotProcessed | TypeProcessed
+
+(* Status of an instance together with the status of its type unification *)
+
+type instance_status = instance_constraint * instance_typing_status
 
 (* Clausal environments *)
 
 type clbinding =
   | Cltyp of name * constr freelisted
-  | Clval of name * constr freelisted * constr freelisted
+  | Clval of name * (constr freelisted * instance_status) * constr freelisted
 
 let map_clb f = function
   | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
-  | Clval (na,cfl1,cfl2) -> Clval (na,map_fl f cfl1,map_fl f cfl2)
+  | Clval (na,(cfl1,pb),cfl2) -> Clval (na,(map_fl f cfl1,pb),map_fl f cfl2)
 
 (* name of defined is erased (but it is pretty-printed) *)
 let clb_name = function
@@ -362,12 +407,15 @@ type hole_kind =
   | CasesType
   | InternalHole
   | TomatchTypeParameter of inductive * int
+  | GoalEvar
+  | ImpossibleCase
 
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * Environ.env * constr * constr
 type evar_defs =
     { evars : evar_map;
       conv_pbs : evar_constraint list;
+      last_mods : existential_key list;
       history : (existential_key * (loc * hole_kind)) list;
       metas : clbinding Metamap.t }
 
@@ -378,46 +426,61 @@ let subst_evar_defs_light sub evd =
     metas = Metamap.map (map_clb (subst_mps sub)) evd.metas }
 
 let create_evar_defs sigma =
-  { evars=sigma; conv_pbs=[]; history=[]; metas=Metamap.empty }
+  { evars=sigma; conv_pbs=[]; last_mods = []; history=[]; metas=Metamap.empty }
+let create_goal_evar_defs sigma =
+  let h = fold (fun mv _ l -> (mv,(dummy_loc,GoalEvar))::l) sigma [] in
+  { evars=sigma; conv_pbs=[]; last_mods = []; history=h; metas=Metamap.empty }
+let empty_evar_defs = create_evar_defs empty
 let evars_of d = d.evars
 let evars_reset_evd evd d = {d with evars = evd}
 let reset_evd (sigma,mmap) d = {d with evars = sigma; metas=mmap}
 let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs}
-let evar_source ev d =
-  try List.assoc ev d.history
+let evar_source evk d =
+  try List.assoc evk d.history
   with Not_found -> (dummy_loc, InternalHole)
 
 (* define the existential of section path sp as the constr body *)
-let evar_define sp body isevars =
-  {isevars with evars = define isevars.evars sp body}
-
-let evar_declare hyps evn ty ?(src=(dummy_loc,InternalHole)) evd =
+let evar_define evk body evd =
   { evd with
-    evars = add evd.evars evn
-      {evar_hyps=hyps; 
-       evar_concl=ty; 
-       evar_body=Evar_empty; 
-       evar_extra=None};
-    history = (evn,src)::evd.history }
+    evars = define evd.evars evk body;
+    last_mods = evk :: evd.last_mods }
+
+let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd =
+  let filter =
+    if filter = None then
+      List.map (fun _ -> true) (named_context_of_val hyps)
+    else
+      (let filter = Option.get filter in
+      assert (List.length filter = List.length (named_context_of_val hyps));
+      filter)
+  in
+  { evd with
+    evars = add evd.evars evk
+      {evar_hyps = hyps;
+       evar_concl = ty;
+       evar_body = Evar_empty;
+       evar_filter = filter;
+       evar_extra = None};
+    history = (evk,src)::evd.history }
 
-let is_defined_evar isevars (n,_) = is_defined isevars.evars n
+let is_defined_evar evd (evk,_) = is_defined evd.evars evk
 
 (* Does k corresponds to an (un)defined existential ? *)
-let is_undefined_evar isevars c = match kind_of_term c with
-  | Evar ev -> not (is_defined_evar isevars ev)
+let is_undefined_evar evd c = match kind_of_term c with
+  | Evar ev -> not (is_defined_evar evd ev)
   | _ -> false
 
-let undefined_evars isevars = 
-  let evd = 
-    fold (fun ev evi sigma -> if evi.evar_body = Evar_empty then 
-	    add sigma ev evi else sigma) 
-      isevars.evars empty
+let undefined_evars evd = 
+  let evars = 
+    fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then 
+	    add sigma evk evi else sigma) 
+      evd.evars empty
   in 
-    { isevars with evars = evd }
+    { evd with evars = evars }
 
 (* extracts conversion problems that satisfy predicate p *)
 (* Note: conv_pbs not satisying p are stored back in reverse order *)
-let get_conv_pbs isevars p =
+let extract_conv_pbs evd p =
   let (pbs,pbs1) = 
     List.fold_left
       (fun (pbs,pbs1) pb ->
@@ -426,11 +489,19 @@ let get_conv_pbs isevars p =
          else 
 	   (pbs,pb::pbs1))
       ([],[])
-      isevars.conv_pbs
+      evd.conv_pbs
   in
-  {isevars with conv_pbs = pbs1},
+  {evd with conv_pbs = pbs1; last_mods = []},
   pbs
 
+let extract_changed_conv_pbs evd p =
+  extract_conv_pbs evd (p evd.last_mods)
+
+let extract_all_conv_pbs evd =
+  extract_conv_pbs evd (fun _ -> true)
+
+let evar_merge evd evars =
+  { evd with evars = merge evd.evars evars }
 
 (**********************************************************)
 (* Sort variables *)
@@ -452,11 +523,35 @@ let pr_sort_constraints (_,sm) = pr_sort_cstrs sm
 
 let meta_list evd = metamap_to_list evd.metas
 
+let undefined_metas evd =
+  List.sort Pervasives.compare (map_succeed (function
+    | (n,Clval(_,_,typ)) -> failwith ""
+    | (n,Cltyp (_,typ))  -> n)
+    (meta_list evd))
+
+let metas_of evd = 
+  List.map (function
+    | (n,Clval(_,_,typ)) -> (n,typ.rebus)
+    | (n,Cltyp (_,typ))  -> (n,typ.rebus))
+    (meta_list evd)
+
+let map_metas_fvalue f evd =
+  { evd with metas =
+      Metamap.map 
+        (function 
+          | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
+          | x -> x) evd.metas }
+
+let meta_opt_fvalue evd mv =
+  match Metamap.find mv evd.metas with
+    | Clval(_,b,_) -> Some b
+    | Cltyp _ -> None
+
 let meta_defined evd mv =
   match Metamap.find mv evd.metas with
     | Clval _ -> true
     | Cltyp _ -> false
- 
+
 let meta_fvalue evd mv =
   match Metamap.find mv evd.metas with
     | Clval(_,b,_) -> b
@@ -470,12 +565,19 @@ let meta_ftype evd mv =
 let meta_declare mv v ?(name=Anonymous) evd =
   { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas }
   
-let meta_assign mv v evd =
+let meta_assign mv (v,pb) evd =
+  match Metamap.find mv evd.metas with
+  | Cltyp(na,ty) ->
+      { evd with
+        metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }
+  | _ -> anomaly "meta_assign: already defined"
+
+let meta_reassign mv (v,pb) evd =
   match Metamap.find mv evd.metas with
-      Cltyp(na,ty) ->
-        { evd with
-          metas = Metamap.add mv (Clval(na,mk_freelisted v, ty)) evd.metas }
-    | _ -> anomaly "meta_assign: already defined"
+  | Clval(na,_,ty) ->
+      { evd with
+        metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }
+  | _ -> anomaly "meta_reassign: not yet defined"
 
 (* If the meta is defined then forget its name *)
 let meta_name evd mv =
@@ -510,10 +612,51 @@ let meta_merge evd1 evd2 =
     metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) 
       evd2.metas (metamap_to_list evd1.metas) }
 
+type metabinding = metavariable * constr * instance_status
+
+let retract_coercible_metas evd =
+  let mc,ml = 
+    Metamap.fold (fun n v (mc,ml) -> 
+      match v with
+	| Clval (na,(b,(UserGiven,CoerceToType as s)),typ) ->
+	    (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml
+	| v ->
+	    mc, Metamap.add n v ml)
+      evd.metas ([],Metamap.empty) in
+  mc, { evd with metas = ml }
+
+let rec list_assoc_in_triple x = function
+    [] -> raise Not_found
+  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l
+
+let subst_defined_metas bl c = 
+  let rec substrec c = match kind_of_term c with
+    | Meta i -> substrec (list_assoc_in_triple i bl)
+    | _ -> map_constr substrec c
+  in try Some (substrec c) with Not_found -> None
+
+(**********************************************************)
+(* Failure explanation *)
+
+type unsolvability_explanation = SeveralInstancesFound of int
 
 (**********************************************************)
 (* Pretty-printing *)
 
+let pr_instance_status (sc,typ) =
+  begin match sc with
+  | IsSubType -> str " [or a subtype of it]"
+  | IsSuperType -> str " [or a supertype of it]"
+  | ConvUpToEta 0 -> mt ()
+  | UserGiven -> mt ()
+  | ConvUpToEta n -> str" [or an eta-expansion up to " ++ int n ++ str" of it]"
+  end ++
+  begin match typ with
+  | CoerceToType -> str " [up to coercion]"
+  | TypeNotProcessed -> mt ()
+  | TypeProcessed -> str " [type is checked]"
+  end
+
 let pr_meta_map mmap =
   let pr_name = function
       Name id -> str"[" ++ pr_id id ++ str"]"
@@ -523,17 +666,22 @@ let pr_meta_map mmap =
       	hov 0 
 	  (pr_meta mv ++ pr_name na ++ str " : " ++
            print_constr b.rebus ++ fnl ())
-    | (mv,Clval(na,b,_)) ->
+    | (mv,Clval(na,(b,s),_)) ->
       	hov 0 
 	  (pr_meta mv ++ pr_name na ++ str " := " ++
-           print_constr b.rebus ++ fnl ())
+           print_constr b.rebus ++ spc () ++ pr_instance_status s ++ fnl ())
   in
   prlist pr_meta_binding (metamap_to_list mmap)
 
-let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+let pr_decl ((id,b,_),ok) =
+  match b with
+  | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
+  | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ 
+      print_constr c ++ str (if ok then ")" else "}")
 
 let pr_evar_info evi =
-  let phyps = pr_idl (List.rev (ids_of_named_context (evar_context evi))) in
+  let decls = List.combine (evar_context evi) (evar_filter evi) in
+  let phyps = prlist_with_sep pr_spc pr_decl (List.rev decls) in
   let pty = print_constr evi.evar_concl in
   let pb =
     match evi.evar_body with
@@ -568,3 +716,6 @@ let pr_evar_defs evd =
     if evd.metas = Metamap.empty then mt() else
       str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
   v 0 (pp_evm ++ cstrs ++ pp_met)
+
+let pr_metaset metas = 
+  str "[" ++ prlist_with_sep spc pr_meta (Metaset.elements metas) ++ str "]"
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index ef6a3d7b..1acc811b 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -1,3 +1,4 @@
+
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,15 +7,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evd.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
+(*i $Id: evd.mli 10883 2008-05-05 13:55:24Z herbelin $ i*)
 
 (*i*)
 open Util
 open Names
 open Term
 open Sign
+open Environ
 open Libnames
 open Mod_subst
+open Termops
 (*i*)
 
 (* The type of mappings for existential variables.
@@ -31,12 +34,23 @@ type evar_body =
 
 type evar_info = {
   evar_concl : constr;
-  evar_hyps : Environ.named_context_val;
+  evar_hyps : named_context_val;
   evar_body : evar_body;
+  evar_filter : bool list;
   evar_extra : Dyn.t option}
 
 val eq_evar_info : evar_info -> evar_info -> bool
+
+val make_evar : named_context_val -> types -> evar_info
+val evar_concl : evar_info -> constr
 val evar_context : evar_info -> named_context
+val evar_filtered_context : evar_info -> named_context
+val evar_hyps : evar_info -> named_context_val
+val evar_body : evar_info -> evar_body
+val evar_filter : evar_info -> bool list
+val evar_unfiltered_env :  evar_info -> env
+val evar_env :  evar_info -> env
+
 type evar_map
 
 val empty : evar_map
@@ -50,17 +64,14 @@ val mem : evar_map -> evar -> bool
 val to_list : evar_map -> (evar * evar_info) list
 val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
 
+val merge : evar_map -> evar_map -> evar_map
+
 val define : evar_map -> evar -> constr -> evar_map
 
 val is_evar : evar_map -> evar -> bool
 
 val is_defined : evar_map -> evar -> bool
 
-val evar_concl : evar_info -> constr
-val evar_hyps : evar_info -> Environ.named_context_val
-val evar_body : evar_info -> evar_body
-val evar_env :  evar_info -> Environ.env
-
 val string_of_existential : evar -> string
 val existential_of_int : int -> evar
 
@@ -101,9 +112,41 @@ val metavars_of : constr -> Metaset.t
 val mk_freelisted : constr -> constr freelisted
 val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
 
+(* Status of an instance found by unification wrt to the meta it solves:
+  - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
+  - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
+  - a term that can be eta-expanded n times while still being a solution
+    (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
+*)
+
+type instance_constraint = 
+    IsSuperType | IsSubType | ConvUpToEta of int | UserGiven
+
+(* Status of the unification of the type of an instance against the type of
+     the meta it instantiates:
+   - CoerceToType means that the unification of types has not been done
+     and that a coercion can still be inserted: the meta should not be
+     substituted freely (this happens for instance given via the
+     "with" binding clause).
+   - TypeProcessed means that the information obtainable from the
+     unification of types has been extracted.
+   - TypeNotProcessed means that the unification of types has not been
+     done but it is known that no coercion may be inserted: the meta
+     can be substituted freely.
+*)
+
+type instance_typing_status =
+    CoerceToType | TypeNotProcessed | TypeProcessed
+
+(* Status of an instance together with the status of its type unification *)
+
+type instance_status = instance_constraint * instance_typing_status
+
+(* Clausal environments *)
+
 type clbinding =
   | Cltyp of name * constr freelisted
-  | Clval of name * constr freelisted * constr freelisted
+  | Clval of name * (constr freelisted * instance_status) * constr freelisted
 
 val map_clb : (constr -> constr) -> clbinding -> clbinding
 
@@ -115,7 +158,9 @@ type evar_defs
 val subst_evar_defs_light : substitution -> evar_defs -> evar_defs
 
 (* create an [evar_defs] with empty meta map: *)
-val create_evar_defs : evar_map -> evar_defs
+val create_evar_defs      : evar_map -> evar_defs
+val create_goal_evar_defs : evar_map -> evar_defs
+val empty_evar_defs : evar_defs
 val evars_of         : evar_defs -> evar_map
 val evars_reset_evd  : evar_map ->  evar_defs -> evar_defs
 
@@ -127,38 +172,57 @@ type hole_kind =
   | CasesType
   | InternalHole
   | TomatchTypeParameter of inductive * int
+  | GoalEvar
+  | ImpossibleCase
 val is_defined_evar :  evar_defs -> existential -> bool
 val is_undefined_evar :  evar_defs -> constr -> bool
 val undefined_evars : evar_defs -> evar_defs
 val evar_declare :
-  Environ.named_context_val -> evar -> types -> ?src:loc * hole_kind ->
-  evar_defs -> evar_defs
+  named_context_val -> evar -> types -> ?src:loc * hole_kind ->
+      ?filter:bool list -> evar_defs -> evar_defs
 val evar_define : evar -> constr -> evar_defs -> evar_defs
 val evar_source : existential_key -> evar_defs -> loc * hole_kind
 
+(* [evar_merge evd evars] extends the evars of [evd] with [evars] *)
+val evar_merge : evar_defs -> evar_map -> evar_defs
+
 (* Unification constraints *)
 type conv_pb = Reduction.conv_pb
-type evar_constraint = conv_pb * Environ.env * constr * constr
+type evar_constraint = conv_pb * env * constr * constr
 val add_conv_pb :  evar_constraint -> evar_defs -> evar_defs
-val get_conv_pbs : evar_defs -> (evar_constraint -> bool) -> 
-  evar_defs * evar_constraint list
+val extract_changed_conv_pbs : evar_defs -> 
+      (existential_key list -> evar_constraint -> bool) ->
+      evar_defs * evar_constraint list
+val extract_all_conv_pbs : evar_defs -> evar_defs * evar_constraint list
+
 
 (* Metas *)
 val meta_list : evar_defs -> (metavariable * clbinding) list
 val meta_defined : evar_defs -> metavariable -> bool
 (* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
    meta has no value *)  
-val meta_fvalue    : evar_defs -> metavariable -> constr freelisted
+val meta_fvalue    : evar_defs -> metavariable -> constr freelisted * instance_status
+val meta_opt_fvalue : evar_defs -> metavariable -> (constr freelisted * instance_status) option
 val meta_ftype     : evar_defs -> metavariable -> constr freelisted
 val meta_name      : evar_defs -> metavariable -> name
 val meta_with_name : evar_defs -> identifier -> metavariable
 val meta_declare   :
   metavariable -> types -> ?name:name -> evar_defs -> evar_defs
-val meta_assign    : metavariable -> constr -> evar_defs -> evar_defs
+val meta_assign    : metavariable -> constr * instance_status -> evar_defs -> evar_defs
+val meta_reassign  : metavariable -> constr * instance_status -> evar_defs -> evar_defs
 
 (* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
 val meta_merge : evar_defs -> evar_defs -> evar_defs
 
+val undefined_metas : evar_defs -> metavariable list
+val metas_of : evar_defs -> metamap
+val map_metas_fvalue : (constr -> constr) -> evar_defs -> evar_defs
+
+type metabinding = metavariable * constr * instance_status
+
+val retract_coercible_metas : evar_defs -> metabinding list * evar_defs
+val subst_defined_metas : metabinding list -> constr -> constr option
+
 (**********************************************************)
 (* Sort variables *)
 
@@ -168,6 +232,11 @@ val whd_sort_variable : evar_map -> constr -> constr
 val set_leq_sort_variable : evar_map -> sorts -> sorts -> evar_map
 val define_sort_variable : evar_map -> sorts -> sorts -> evar_map
 
+(**********************************************************)
+(* Failure explanation *)
+
+type unsolvability_explanation = SeveralInstancesFound of int
+
 (*********************************************************************)
 (* debug pretty-printer: *)
 
@@ -175,3 +244,4 @@ val pr_evar_info : evar_info -> Pp.std_ppcmds
 val pr_evar_map  : evar_map -> Pp.std_ppcmds
 val pr_evar_defs : evar_defs -> Pp.std_ppcmds
 val pr_sort_constraints : evar_map -> Pp.std_ppcmds
+val pr_metaset : Metaset.t -> Pp.std_ppcmds
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index eeddcb64..2325baec 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indrec.ml 9519 2007-01-22 18:13:29Z notin $ *)
+(* $Id: indrec.ml 10410 2007-12-31 13:11:55Z msozeau $ *)
 
 open Pp
 open Util
@@ -31,7 +31,7 @@ open Sign
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of bool * sorts * inductive
   | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
+  | NotMutualInScheme of inductive * inductive
 
 exception RecursionSchemeError of recursion_scheme_error
 
@@ -78,7 +78,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
       let depind = build_dependent_inductive env indf' in
       let deparsign = (Anonymous,None,depind)::arsign in
 
-      let ci = make_default_case_info env RegularStyle ind in
+      let ci = make_case_info env ind RegularStyle in
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
@@ -157,7 +157,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
                   (match dest_recarg ra with 
 	            | Mrec j when is_rec -> (depPvect.(j),rest)
 	            | Imbr _  -> 
-		        Options.if_verbose warning "Ignoring recursive call"; 
+		        Flags.if_verbose warning "Ignoring recursive call"; 
 		        (None,rest) 
                     | _ -> (None, rest))
 	  in 
@@ -275,19 +275,18 @@ let mis_make_indrec env sigma listdepkind mib =
     Array.create mib.mind_ntypes (None : (bool * constr) option) in 
   let _ = 
     let rec 
-      assign k = function 
-	| [] -> ()
-        | (indi,mibi,mipi,dep,_)::rest -> 
-            (Array.set depPvec (snd indi) (Some(dep,mkRel k));
-             assign (k-1) rest)
+	assign k = function 
+	  | [] -> ()
+          | (indi,mibi,mipi,dep,_)::rest -> 
+              (Array.set depPvec (snd indi) (Some(dep,mkRel k));
+               assign (k-1) rest)
     in 
-    assign nrec listdepkind in 
+      assign nrec listdepkind in 
   let recargsvec =
     Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
- (* recarg information for non recursive parameters *)
+  (* recarg information for non recursive parameters *)
   let rec recargparn l n = 
-    if n = 0 then l else recargparn (mk_norec::l) (n-1) 
-  in
+    if n = 0 then l else recargparn (mk_norec::l) (n-1) in
   let recargpar = recargparn [] (nparams-nparrec) in
   let make_one_rec p =
     let makefix nbconstruct =
@@ -296,97 +295,97 @@ let mis_make_indrec env sigma listdepkind mib =
 	    let tyi = snd indi in
 	    let nctyi =
               Array.length mipi.mind_consnames in (* nb constructeurs du type*)
-
+	      
             (* arity in the context of the fixpoint, i.e.
-                P1..P_nrec f1..f_nbconstruct *)
+               P1..P_nrec f1..f_nbconstruct *)
 	    let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family(indi,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 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 *)
+	      
+            (* 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' = extended_rel_list (dect+nrec) lnamesparrec in
 	    let args'' = extended_rel_list ndepar lnonparrec in
             let indf' = make_ind_family(indi,args'@args'') in
-
+	      
 	    let branches = 
 	      let constrs = get_constructors env indf' in
 	      let fi = rel_vect (dect-i-nctyi) nctyi in
 	      let vecfi = Array.map 
-			    (fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
-			    fi 
+		(fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
+		fi 
 	      in
-	      array_map3
-		(make_rec_branch_arg env sigma 
-		   (nparrec,depPvec,larsign))
-                vecfi constrs (dest_subterms recargsvec.(tyi)) 
+		array_map3
+		  (make_rec_branch_arg env sigma 
+		      (nparrec,depPvec,larsign))
+                  vecfi constrs (dest_subterms recargsvec.(tyi)) 
 	    in
-
+	      
 	    let j = (match depPvec.(tyi) with 
-		       | Some (_,c) when isRel c -> destRel c 
-		       | _ -> assert false) 
+	      | Some (_,c) when isRel c -> destRel c 
+	      | _ -> assert false) 
 	    in
-
-	      (* Predicate in the context of the case *)
-
+	      
+	    (* Predicate in the context of the case *)
+	      
 	    let depind' = build_dependent_inductive env indf' in
 	    let arsign',_ = get_arity env indf' in
 	    let deparsign' = (Anonymous,None,depind')::arsign' in
-
+	      
 	    let pargs =
 	      let nrpar = extended_rel_list (2*ndepar) lnonparrec 
 	      and nrar = if dep then extended_rel_list 0 deparsign'
-	      else extended_rel_list 1 arsign'
+		else extended_rel_list 1 arsign'
 	      in nrpar@nrar
-
+		
 	    in
 
-		(* body of i-th component of the mutual fixpoint *)
+	    (* body of i-th component of the mutual fixpoint *)
 	    let deftyi = 
-	      let ci = make_default_case_info env RegularStyle indi in
+	      let ci = make_case_info env indi RegularStyle in
 	      let concl = applist (mkRel (dect+j+ndepar),pargs) in 
 	      let pred =
 		it_mkLambda_or_LetIn_name env 
 		  ((if dep then mkLambda_name env else mkLambda)
-		   (Anonymous,depind',concl))
+		      (Anonymous,depind',concl))
 		  arsign'
 	      in
-	      it_mkLambda_or_LetIn_name env
-		(mkCase (ci, pred, 
-		             mkRel 1,
-			     branches))
-		(lift_rel_context nrec deparsign)
+		it_mkLambda_or_LetIn_name env
+		  (mkCase (ci, pred, 
+		          mkRel 1,
+			  branches))
+		  (lift_rel_context nrec deparsign)
 	    in
-
+	      
 	    (* type of i-th component of the mutual fixpoint *)
-
+	      
 	    let typtyi =
-	    let concl = 
-	      let pargs = if dep then extended_rel_vect 0 deparsign
-	      else extended_rel_vect 1 arsign
-	      in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
-	    in it_mkProd_or_LetIn_name env
+	      let concl = 
+		let pargs = if dep then extended_rel_vect 0 deparsign
+		  else extended_rel_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) 
-                 (deftyi::ldef) rest
+	      mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) 
+                (deftyi::ldef) rest
         | [] -> 
 	    let fixn = Array.of_list (List.rev ln) in
             let fixtyi = Array.of_list (List.rev ltyp) in
             let fixdef = Array.of_list (List.rev ldef) in 
             let names = Array.create nrec (Name(id_of_string "F")) in
-	    mkFix ((fixn,p),(names,fixtyi,fixdef))
+	      mkFix ((fixn,p),(names,fixtyi,fixdef))
       in 
-	      mrec 0 [] [] [] 
+	mrec 0 [] [] [] 
     in 
     let rec make_branch env i = function 
       | (indi,mibi,mipi,dep,_)::rest ->
@@ -404,27 +403,28 @@ let mis_make_indrec env sigma listdepkind mib =
 		type_rec_branch
                   true dep env sigma (vargs,depPvec,i+j) tyi cs recarg
 	      in 
-	      mkLambda_string "f" p_0
-		(onerec (push_rel (Anonymous,None,p_0) env) (j+1))
+		mkLambda_string "f" p_0
+		  (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
 	  in onerec env 0
       | [] -> 
 	  makefix i listdepkind
-    in 
+    in
     let rec put_arity env i = function 
       | (indi,_,_,dep,kinds)::rest -> 
 	  let indf = make_ind_family (indi,extended_rel_list i lnamesparrec) in
 	  let typP = make_arity env dep indf (new_sort_in_family kinds) in
-	  mkLambda_string "P" typP
-	    (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
+	    mkLambda_string "P" typP
+	      (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
       | [] -> 
 	  make_branch env 0 listdepkind 
-    in 
-
-      (* Body on make_one_rec *)
+    in
+      
+    (* Body on make_one_rec *)
     let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
+      
       if (mis_is_recursive_subset
-	     (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
-	     mipi.mind_recargs) 
+	(List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
+	mipi.mind_recargs) 
       then 
 	let env' = push_rel_context lnamesparrec env in
 	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) 
@@ -432,15 +432,15 @@ let mis_make_indrec env sigma listdepkind mib =
       else 
 	mis_make_case_com (Some dep) env sigma indi (mibi,mipi) kind 
   in 
-      (* Body of mis_make_indrec *)
-  list_tabulate make_one_rec nrec
+    (* Body of mis_make_indrec *)
+    list_tabulate make_one_rec nrec
 
 (**********************************************************************)
 (* This builds elimination predicate for Case tactic *)
 
 let make_case_com depopt env sigma ity kind =
   let (mib,mip) = lookup_mind_specif env ity in 
-  mis_make_case_com depopt env sigma ity (mib,mip) kind
+    mis_make_case_com depopt env sigma ity (mib,mip) kind
 
 let make_case_dep env   = make_case_com (Some true) env
 let make_case_nodep env = make_case_com (Some false) env 
@@ -459,7 +459,7 @@ let change_sort_arity sort =
     | Sort _ -> mkSort sort
     | _ -> assert false
   in 
-  drec 
+    drec 
 
 (* [npar] is the number of expected arguments (then excluding letin's) *)
 let instantiate_indrec_scheme sort =
@@ -501,13 +501,13 @@ let instantiate_type_indrec_scheme sort npars term =
 
 let check_arities listdepkind = 
   let _ = List.fold_left
-    (fun ln ((_,ni),mibi,mipi,dep,kind) -> 
+    (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> 
        let id = mipi.mind_typename  in
        let kelim = elim_sorts (mibi,mipi) in
        if not (List.exists ((=) kind) kelim) then raise
 	 (RecursionSchemeError (BadInduction (dep,id,new_sort_in_family kind)))
        else if List.mem ni ln then raise
-	 (RecursionSchemeError NotMutualInScheme)
+	 (RecursionSchemeError (NotMutualInScheme (mind,mind)))
        else ni::ln)
 	    [] listdepkind
   in true
@@ -520,11 +520,11 @@ let build_mutual_indrec env sigma = function
     	(List.map
 	   (function (mind',mibi',mipi',dep',s') ->
 	      let (sp',_) = mind' in
-	      if sp=sp' then 
+	      if sp=sp' then
                 let (mibi',mipi') = lookup_mind_specif env mind' in
-		(mind',mibi',mipi',dep',s') 
-	      else 
-		raise (RecursionSchemeError NotMutualInScheme))
+		(mind',mibi',mipi',dep',s')
+	      else
+		  raise (RecursionSchemeError (NotMutualInScheme (mind,mind'))))
 	   lrecspec)
       in
       let _ = check_arities listdepkind in 
@@ -535,7 +535,7 @@ let build_indrec env sigma ind =
   let (mib,mip) = lookup_mind_specif env ind in
   let kind = inductive_sort_family mip in
   let dep = kind <> InProp in
-  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
+    List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
 
 (**********************************************************************)
 (* To handle old Case/Match syntax in Pretyping                       *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index e5eb07f5..6f177474 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indrec.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
+(*i $Id: indrec.mli 9831 2007-05-17 18:55:42Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -22,7 +22,7 @@ open Evd
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of bool * sorts * inductive
   | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
+  | NotMutualInScheme of inductive * inductive
 
 exception RecursionSchemeError of recursion_scheme_error
 
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 14136f61..0daff713 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductiveops.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
+(* $Id: inductiveops.ml 10114 2007-09-06 07:36:14Z herbelin $ *)
 
 open Util
 open Names
@@ -131,21 +131,16 @@ let allowed_sorts env (kn,i as ind) =
   mip.mind_kelim
 
 (* Annotation for cases *)
-let make_case_info env ind style pats_source =
+let make_case_info env ind style =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let print_info =
-    { ind_nargs = mip.mind_nrealargs;
-      style     = style;
-      source    = pats_source } in
+  let print_info = { ind_nargs = mip.mind_nrealargs; style = style } in
   { ci_ind     = ind;
     ci_npar    = mib.mind_nparams;
     ci_cstr_nargs = mip.mind_consnrealdecls;
     ci_pp_info = print_info }
 
 let make_default_case_info env style ind =
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
   make_case_info env ind style
-    (Array.map (fun _ -> RegularPat) mip.mind_consnames)
 
 (*s Useful functions *)
 
@@ -398,30 +393,19 @@ let arity_of_case_predicate env (ind,params) dep k =
 (* A function which checks that a term well typed verifies both
    syntactic conditions *)
 
-let control_only_guard env = 
-  let rec control_rec c = match kind_of_term c with
-    | Rel _ | Var _    -> ()
-    | Sort _ | Meta _ -> ()
-    | Ind _       -> ()
-    | Construct _ -> ()
-    | Const _        -> ()
-    | CoFix (_,(_,tys,bds) as cofix) ->
-	Inductive.check_cofix env cofix;
-	Array.iter control_rec tys;
-	Array.iter control_rec bds;
-    | Fix (_,(_,tys,bds) as fix) ->
-	Inductive.check_fix env fix; 
-	Array.iter control_rec tys;
-	Array.iter control_rec bds;
-    | Case(_,p,c,b) -> control_rec p;control_rec c;Array.iter control_rec b
-    | Evar (_,cl)        -> Array.iter control_rec cl
-    | App (c,cl)         -> control_rec c; Array.iter control_rec cl
-    | Cast (c1,_, c2)  -> control_rec c1; control_rec c2
-    | Prod (_,c1,c2)     -> control_rec c1; control_rec c2
-    | Lambda (_,c1,c2)   -> control_rec c1; control_rec c2
-    | LetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3
-  in 
-  control_rec 
+let control_only_guard env c = 
+  let check_fix_cofix e c = match kind_of_term c with
+    | CoFix (_,(_,_,_) as cofix) ->
+	Inductive.check_cofix e cofix
+    | Fix (_,(_,_,_) as fix) ->
+	Inductive.check_fix e fix
+    | _ -> ()
+  in
+  let rec iter env c = 
+    check_fix_cofix env c; 
+    iter_constr_with_full_binders push_rel iter env c
+  in
+  iter env c
 
 let subst_inductive subst (kn,i as ind) = 
   let kn' = Mod_subst.subst_kn subst kn in
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index d49b64d9..9e370fec 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductiveops.mli 9194 2006-10-01 09:25:19Z herbelin $ i*)
+(*i $Id: inductiveops.mli 9707 2007-03-15 16:36:15Z herbelin $ i*)
 
 open Names
 open Term
@@ -105,9 +105,11 @@ val arity_of_case_predicate :
 val type_case_branches_with_names :
   env -> inductive * constr list -> unsafe_judgment -> constr ->
     types array * types
-val make_case_info :
-  env -> inductive -> case_style -> pattern_source array -> case_info
+val make_case_info : env -> inductive -> case_style -> case_info
+
+(*i Compatibility 
 val make_default_case_info : env -> case_style -> inductive -> case_info
+i*)
 
 (********************)
 val control_only_guard : env -> types -> unit
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index 65ce2ef4..aaa4c3f0 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: matching.ml 9280 2006-10-25 21:37:37Z herbelin $ *)
+(* $Id: matching.ml 10451 2008-01-18 17:20:28Z barras $ *)
 
 (*i*)
 open Util
@@ -153,7 +153,7 @@ let matches_core convert allow_partial_app pat c =
 	  sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2
 
       | PRef (ConstRef _ as ref), _ when convert <> None ->
-	  let (env,evars) = out_some convert in
+	  let (env,evars) = Option.get convert in
 	  let c = constr_of_global ref in
 	  if is_conv env evars c cT then sigma
 	  else raise PatternMatchingFailure
@@ -161,7 +161,8 @@ let matches_core convert allow_partial_app pat c =
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
 	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_nargs.(0) b2 in
 	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_nargs.(1) b2' in
-	  let n = List.length ctx and n' = List.length ctx' in
+	  let n = rel_context_length ctx in
+          let n' = rel_context_length ctx' in
 	  if noccur_between 1 n b2 & noccur_between 1 n' b2' then
 	    let s = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx in
 	    let s' = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx' in
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index 3060ee03..5df5c9fb 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pattern.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: pattern.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
 
 open Util
 open Names
@@ -92,7 +92,7 @@ let head_of_constr_reference c = match kind_of_term c with
 let rec pattern_of_constr t =
   match kind_of_term t with
     | Rel n  -> PRel n
-    | Meta n -> PMeta (Some (id_of_string (string_of_int n)))
+    | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n)))
     | Var id -> PVar id
     | Sort (Prop c) -> PSort (RProp c)
     | Sort (Type _) -> PSort (RType None)
@@ -185,7 +185,7 @@ let rec subst_pattern subst pat = match pat with
 	if c' == c && c1' == c1 && c2' == c2 then pat else
 	  PIf (c',c1',c2')
   | PCase ((a,b,ind,n as cs),typ,c,branches) ->
-      let ind' = option_smartmap (Inductiveops.subst_inductive subst) ind in
+      let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in
       let typ' = subst_pattern subst typ in 
       let c' = subst_pattern subst c in
       let branches' = array_smartmap (subst_pattern subst) branches in
@@ -216,14 +216,14 @@ let rec pat_of_raw metas vars = function
       PRef r
   (* Hack pour ne pas réécrire une interprétation complète des patterns*)
   | RApp (_, RPatVar (_,(true,n)), cl) ->
-      PSoApp (n, List.map (pat_of_raw metas vars) cl)
+      metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
   | RApp (_,c,cl) -> 
       PApp (pat_of_raw metas vars c,
 	    Array.of_list (List.map (pat_of_raw metas vars) cl))
-  | RLambda (_,na,c1,c2) ->
+  | RLambda (_,na,bk,c1,c2) ->
       PLambda (na, pat_of_raw metas vars c1,
 	       pat_of_raw metas (na::vars) c2)
-  | RProd (_,na,c1,c2) ->
+  | RProd (_,na,bk,c1,c2) ->
       PProd (na, pat_of_raw metas vars c1,
 	       pat_of_raw metas (na::vars) c2)
   | RLetIn (_,na,c1,c2) ->
@@ -234,18 +234,18 @@ let rec pat_of_raw metas vars = function
   | RHole _ ->
       PMeta None
   | RCast (_,c,_) ->
-      Options.if_verbose
+      Flags.if_verbose
         Pp.warning "Cast not taken into account in constr pattern";
       pat_of_raw metas vars c
   | RIf (_,c,(_,None),b1,b2) ->
       PIf (pat_of_raw metas vars c,
            pat_of_raw metas vars b1,pat_of_raw metas vars b2)
   | RLetTuple (loc,nal,(_,None),b,c) ->
-      let mkRLambda c na = RLambda (loc,na,RHole (loc,Evd.InternalHole),c) in
+      let mkRLambda c na = RLambda (loc,na,Explicit,RHole (loc,Evd.InternalHole),c) in
       let c = List.fold_left mkRLambda c nal in
       PCase ((LetStyle,[|1|],None,None),PMeta None,pat_of_raw metas vars b,
              [|pat_of_raw metas vars c|])
-  | RCases (loc,p,[c,(na,indnames)],brs) ->
+  | RCases (loc,sty,p,[c,(na,indnames)],brs) ->
       let pred,ind_nargs, ind = match p,indnames with
 	| Some p, Some (_,ind,n,nal) ->
 	    rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p)),
@@ -259,7 +259,7 @@ let rec pat_of_raw metas vars = function
 	Array.init (List.length brs) (pat_of_raw_branch loc metas vars ind brs)
       in
       let cstr_nargs,brs = (Array.map fst cbrs, Array.map snd cbrs) in
-      PCase ((RegularStyle,cstr_nargs,ind,ind_nargs), pred,
+      PCase ((sty,cstr_nargs,ind,ind_nargs), pred,
              pat_of_raw metas vars c, brs)
              
   | r ->
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 59cdad04..a513d558 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretype_errors.ml 9217 2006-10-05 17:31:23Z notin $ *)
+(* $Id: pretype_errors.ml 10860 2008-04-27 21:39:08Z herbelin $ *)
 
 open Util
 open Stdpp
@@ -25,12 +25,14 @@ type pretype_error =
   (* Unification *)
   | OccurCheck of existential_key * constr
   | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.hole_kind
+  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * 
+      Evd.unsolvability_explanation option
   | CannotUnify of constr * constr
-  | CannotUnifyLocal of Environ.env * constr * constr * constr
+  | CannotUnifyLocal of constr * constr * constr
   | CannotUnifyBindingType of constr * constr
   | CannotGeneralize of constr
-  | NoOccurrenceFound of constr
+  | NoOccurrenceFound of constr * identifier option
+  | CannotFindWellTypedAbstraction of constr * constr list
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -51,7 +53,7 @@ let j_nf_evar sigma j =
 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=type_app (nf_evar sigma) v;utj_type=t}
+  {utj_val=nf_evar sigma v;utj_type=t}
 
 let env_ise sigma env =
   let sign = named_context_val env in
@@ -60,7 +62,7 @@ let env_ise sigma env =
   Sign.fold_rel_context
     (fun (na,b,ty) e ->
       push_rel
-        (na, option_map (nf_evar sigma) b, nf_evar sigma ty)
+        (na, Option.map (nf_evar sigma) b, nf_evar sigma ty)
         e)
     ctxt
     ~init:env0
@@ -76,7 +78,7 @@ let contract env lc =
 	  env
       | _ -> 
 	  let t' = substl !l t in
-	  let c' = option_map (substl !l) c in
+	  let c' = Option.map (substl !l) c in
 	  let na' = named_hd env t' na in
 	  l := (mkRel 1) :: List.map (lift 1) !l;
 	  push_rel (na',c',t') env in
@@ -152,18 +154,22 @@ let error_not_clean env sigma ev c (loc,k) =
   raise_with_loc loc
     (PretypeError (env_ise sigma env,  NotClean (ev,c,k)))
 
-let error_unsolvable_implicit loc env sigma e =
-  raise_with_loc loc (PretypeError (env_ise sigma env, UnsolvableImplicit e))
+let error_unsolvable_implicit loc env sigma evi e explain =
+  raise_with_loc loc
+    (PretypeError (env_ise sigma env, UnsolvableImplicit (evi, e, explain)))
 
 let error_cannot_unify env sigma (m,n) =
   raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
 
-let error_cannot_unify_local env sigma (e,m,n,sn) = 
-  raise (PretypeError (env_ise sigma env,CannotUnifyLocal (e,m,n,sn)))
+let error_cannot_unify_local env sigma (m,n,sn) = 
+  raise (PretypeError (env_ise sigma env,CannotUnifyLocal (m,n,sn)))
 
 let error_cannot_coerce env sigma (m,n) =
   raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
 
+let error_cannot_find_well_typed_abstraction env sigma p l =
+  raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l)))
+
 (*s Ml Case errors *)
 
 let error_cant_find_case_type_loc loc env sigma expr =
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index 137ef639..6ad2793f 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretype_errors.mli 9217 2006-10-05 17:31:23Z notin $ i*)
+(*i $Id: pretype_errors.mli 10860 2008-04-27 21:39:08Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -27,12 +27,14 @@ type pretype_error =
   (* Unification *)
   | OccurCheck of existential_key * constr
   | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.hole_kind
+  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * 
+      Evd.unsolvability_explanation option
   | CannotUnify of constr * constr
-  | CannotUnifyLocal of Environ.env * constr * constr * constr
+  | CannotUnifyLocal of constr * constr * constr
   | CannotUnifyBindingType of constr * constr
   | CannotGeneralize of constr
-  | NoOccurrenceFound of constr
+  | NoOccurrenceFound of constr * identifier option
+  | CannotFindWellTypedAbstraction of constr * constr list
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -93,11 +95,15 @@ val error_not_clean :
   env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
 
 val error_unsolvable_implicit :
-  loc -> env -> Evd.evar_map -> Evd.hole_kind -> 'b
+  loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind -> 
+      Evd.unsolvability_explanation option -> 'b
 
 val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b
 
-val error_cannot_unify_local : env -> Evd.evar_map -> Environ.env * constr * constr * constr -> 'b
+val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b
+
+val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map ->
+      constr -> constr list -> 'b
 
 (*s Ml Case errors *)
 
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 0db64a52..5f0999cb 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretyping.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: pretyping.ml 11047 2008-06-03 23:08:00Z msozeau $ *)
 
 open Pp
 open Util
@@ -43,6 +43,34 @@ open Inductiveops
 
 (************************************************************************)
 
+(* An auxiliary function for searching for fixpoint guard indexes *)
+
+exception Found of int array
+
+let search_guard loc env possible_indexes fixdefs = 
+  (* Standard situation with only one possibility for each fix. *)
+  (* We treat it separately in order to get proper error msg. *)
+  if List.for_all (fun l->1=List.length l) possible_indexes then 
+    let indexes = Array.of_list (List.map List.hd possible_indexes) in 
+    let fix = ((indexes, 0),fixdefs) in
+    (try check_fix env fix with 
+       | e -> if loc = dummy_loc then raise e else Stdpp.raise_with_loc loc e);
+    indexes
+  else
+    (* we now search recursively amoungst all combinations *)
+    (try     
+       List.iter 
+	 (fun l -> 
+	    let indexes = Array.of_list l in 
+	    let fix = ((indexes, 0),fixdefs) in
+	    try check_fix env fix; raise (Found indexes) 
+	    with TypeError _ -> ())
+	 (list_combinations possible_indexes); 
+       let errmsg = "cannot guess decreasing argument of fix" in 
+       if loc = dummy_loc then error errmsg else 
+	 user_err_loc (loc,"search_guard", Pp.str errmsg)
+     with Found indexes -> indexes)
+
 (* To embed constr in rawconstr *)
 let ((constr_in : constr -> Dyn.t),
      (constr_out : Dyn.t -> constr)) = create "constr"
@@ -70,7 +98,7 @@ sig
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
   
-  val understand_tcc :
+  val understand_tcc : ?resolve_classes:bool ->
     evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
 
   val understand_tcc_evars :
@@ -129,7 +157,7 @@ sig
     rawconstr -> unsafe_type_judgment
 
   val pretype_gen :
-    evar_defs ref -> env -> 
+    evar_defs ref -> env ->
     var_map * (identifier * identifier option) list ->
     typing_constraint -> rawconstr -> constr
 
@@ -143,90 +171,83 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
   let allow_anonymous_refs = ref false
 
-  let evd_comb0 f isevars =
-    let (evd',x) = f !isevars in
-      isevars := evd';
+  let evd_comb0 f evdref =
+    let (evd',x) = f !evdref in
+      evdref := evd';
       x
 
-  let evd_comb1 f isevars x =
-    let (evd',y) = f !isevars x in
-      isevars := evd';
+  let evd_comb1 f evdref x =
+    let (evd',y) = f !evdref x in
+      evdref := evd';
       y
 
-  let evd_comb2 f isevars x y =
-    let (evd',z) = f !isevars x y in
-      isevars := evd';
+  let evd_comb2 f evdref x y =
+    let (evd',z) = f !evdref x y in
+      evdref := evd';
       z
 
-  let evd_comb3 f isevars x y z =
-    let (evd',t) = f !isevars x y z in
-      isevars := evd';
+  let evd_comb3 f evdref x y z =
+    let (evd',t) = f !evdref x y z in
+      evdref := evd';
       t
 	
   let mt_evd = Evd.empty
     
-  let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-      
   (* Utilisé pour inférer le prédicat des Cases *)
   (* Semble exagérement fort *)
   (* Faudra préférer une unification entre les types de toutes les clauses *)
   (* et autoriser des ? à rester dans le résultat de l'unification *)
   
-  let evar_type_fixpoint loc env isevars lna lar vdefj =
+  let evar_type_fixpoint loc env evdref lna lar vdefj =
     let lt = Array.length vdefj in 
       if Array.length lar = lt then 
 	for i = 0 to lt-1 do 
-          if not (e_cumul env isevars (vdefj.(i)).uj_type
+          if not (e_cumul env evdref (vdefj.(i)).uj_type
 		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env (evars_of !isevars)
+            error_ill_typed_rec_body_loc loc env (evars_of !evdref)
               i lna vdefj lar
 	done
 
-  let check_branches_message loc env isevars c (explft,lft) = 
+  let check_branches_message loc env evdref c (explft,lft) = 
     for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env isevars lft.(i) explft.(i)) then 
-	let sigma = evars_of !isevars in
+      if not (e_cumul env evdref lft.(i) explft.(i)) then 
+	let sigma = evars_of !evdref in
 	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
     done
 
   (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon loc env isevars j = function
+  let inh_conv_coerce_to_tycon loc env evdref j = function
     | None -> j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
+    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
 
   let push_rels vars env = List.fold_right push_rel vars env
 
-  (*
-    let evar_type_case isevars env ct pt lft p c =
-    let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
-    in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
-  *)
+  (* used to enforce a name in Lambda when the type constraints itself
+     is named, hence possibly dependent *)
 
-  let strip_meta id = (* For Grammar v7 compatibility *)
-    let s = string_of_id id in
-      if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
-      else id
+  let orelse_name name name' = match name with
+    | Anonymous -> name'
+    | _ -> name
 
   let pretype_id loc env (lvar,unbndltacvars) id =
-    let id = strip_meta id in (* May happen in tactics defined by Grammar *)
-      try
-	let (n,typ) = lookup_rel_id id (rel_context env) in
-	  { uj_val  = mkRel n; uj_type = type_app (lift n) typ }
-      with Not_found ->
-	try
-	  List.assoc id lvar
-	with Not_found ->
-	  try
-	    let (_,_,typ) = lookup_named id env in
-	      { uj_val  = mkVar id; uj_type = typ }
-	  with Not_found ->
-	    try (* To build a nicer ltac error message *)
-	      match List.assoc id unbndltacvars with
-		| None -> user_err_loc (loc,"",
-					str "variable " ++ pr_id id ++ str " should be bound to a term")
-		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-	    with Not_found ->
-	      error_var_not_found_loc loc id
+    try
+      let (n,typ) = lookup_rel_id id (rel_context env) in
+      { uj_val  = mkRel n; uj_type = lift n typ }
+    with Not_found ->
+    try
+      List.assoc id lvar
+    with Not_found ->
+    try
+      let (_,_,typ) = lookup_named id env in
+      { uj_val  = mkVar id; uj_type = typ }
+    with Not_found ->
+    try (* To build a nicer ltac error message *)
+      match List.assoc id unbndltacvars with
+      | None -> user_err_loc (loc,"",
+	  str "variable " ++ pr_id id ++ str " should be bound to a term")
+      | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
+    with Not_found ->
+      error_var_not_found_loc loc id
 
   (* make a dependent predicate from an undependent one *)
 
@@ -251,7 +272,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   (*************************************************************************)
   (* Main pretyping function                                               *)
 
-  let pretype_ref isevars env ref = 
+  let pretype_ref evdref env ref = 
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
 
@@ -259,30 +280,32 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     | RProp c -> judge_of_prop_contents c
     | RType _ -> judge_of_new_Type ()
 
-  (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [(evars_of isevars)] and *)
+  exception Found of fixpoint
+
+  (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
+  (* in environment [env], with existential variables [evdref] and *)
   (* the type constraint tycon *)
-  let rec pretype (tycon : type_constraint) env isevars lvar = function
+  let rec pretype (tycon : type_constraint) env evdref lvar = function
     | RRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env isevars
-	  (pretype_ref isevars env ref)
+	inh_conv_coerce_to_tycon loc env evdref
+	  (pretype_ref evdref env ref)
 	  tycon
 
     | RVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env isevars
+	inh_conv_coerce_to_tycon loc env evdref
 	  (pretype_id loc env lvar id)
 	  tycon
 
-    | REvar (loc, ev, instopt) ->
+    | REvar (loc, evk, instopt) ->
 	(* Ne faudrait-il pas s'assurer que hyps est bien un
 	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find (evars_of !isevars) ev) in
+	let hyps = evar_filtered_context (Evd.find (evars_of !evdref) evk) in
 	let args = match instopt with
           | None -> instance_from_named_context hyps
           | Some inst -> failwith "Evar subtitutions not implemented" in
-	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
-	  inh_conv_coerce_to_tycon loc env isevars j tycon
+	let c = mkEvar (evk, args) in
+	let j = (Retyping.get_judgment_of env (evars_of !evdref) c) in
+	  inh_conv_coerce_to_tycon loc env evdref j tycon
 
     | RPatVar (loc,(someta,n)) -> 
 	anomaly "Found a pattern variable in a rawterm to type"
@@ -292,26 +315,26 @@ module Pretyping_F (Coercion : Coercion.S) = struct
           match tycon with 
             | Some (None, ty) -> ty
             | None | Some _ ->
-		e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
-	  { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
+		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
 
     | RRec (loc,fixkind,names,bl,lar,vdef) ->
 	let rec type_bl env ctxt = function
             [] -> ctxt
-          | (na,None,ty)::bl ->
-              let ty' = pretype_type empty_valcon env isevars lvar ty in
+          | (na,bk,None,ty)::bl ->
+              let ty' = pretype_type empty_valcon env evdref lvar ty in
               let dcl = (na,None,ty'.utj_val) in
 		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-          | (na,Some bd,ty)::bl ->
-              let ty' = pretype_type empty_valcon env isevars lvar ty in
-              let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
+          | (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 ty in
               let dcl = (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
 	let larj =
           array_map2
             (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
+               pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
             ctxtv lar in
 	let lara = Array.map (fun a -> a.utj_val) larj in
 	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
@@ -328,115 +351,111 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		 decompose_prod_n_assum (rel_context_length ctxt)
                    (lift nbfix ftys.(i)) in
                let nenv = push_rel_context ctxt newenv in
-               let j = pretype (mk_tycon ty) nenv isevars lvar def in
+               let j = pretype (mk_tycon ty) nenv evdref lvar def in
 		 { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
 		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
             ctxtv vdef in
-	evar_type_fixpoint loc env isevars names ftys vdefj;
+	evar_type_fixpoint loc env evdref names ftys vdefj;
 	let fixj = match fixkind with
 	  | RFix (vn,i) ->
-	      let guard_indexes = Array.mapi 
+	      (* First, let's find the guard indexes. *)
+	      (* If recursive argument was not given by user, we try all args.
+	         An earlier approach was to look only for inductive arguments,
+		 but doing it properly involves delta-reduction, and it finally 
+                 doesn't seem worth the effort (except for huge mutual 
+		 fixpoints ?) *)
+	      let possible_indexes = Array.to_list (Array.mapi 
 		(fun i (n,_) -> match n with 
-		   | Some n -> n 
-		   | None -> 
-		       (* Recursive argument was not given by the user : We
-			  check that there is only one inductive argument *)
-		       let ctx = ctxtv.(i) in 
-		       let isIndApp t = 
-			 isInd (fst (decompose_app (strip_head_cast t))) in
-			 (* This could be more precise (e.g. do some delta) *)
-		       let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
-		       try (list_unique_index true lb) - 1
-		       with Not_found -> 
-			 Util.user_err_loc
-			   (loc,"pretype",
-			    Pp.str "cannot guess decreasing argument of fix"))
-		vn 
-	      in
-	      let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in
-	      (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
-	      make_judge (mkFix fix) ftys.(i)
-	  | RCoFix i -> 
+		   | Some n -> [n]
+		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
+		vn)
+	      in 
+	      let fixdecls = (names,ftys,Array.map j_val vdefj) in 
+	      let indexes = search_guard loc env possible_indexes fixdecls in 
+	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
+	  | RCoFix i ->
 	      let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
 	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
-	inh_conv_coerce_to_tycon loc env isevars fixj tycon
+	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
     | RSort (loc,s) ->
-	inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+	inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon
 
     | RApp (loc,f,args) -> 
-	let fj = pretype empty_tycon env isevars lvar f in
+	let fj = pretype empty_tycon env evdref lvar f in
  	let floc = loc_of_rawconstr f in
 	let rec apply_rec env n resj = function
 	  | [] -> resj
 	  | c::rest ->
 	      let argloc = loc_of_rawconstr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
-              let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
+	      let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in
+              let resty = whd_betadeltaiota env (evars_of !evdref) resj.uj_type in
       		match kind_of_term resty with
 		  | Prod (na,c1,c2) ->
-		      let hj = pretype (mk_tycon c1) env isevars lvar c in
+		      let hj = pretype (mk_tycon c1) env evdref lvar c in
 		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
 			apply_rec env (n+1) 
 			  { uj_val = value;
 			    uj_type = typ }
 			  rest
 		  | _ ->
-		      let hj = pretype empty_tycon env isevars lvar c in
+		      let hj = pretype empty_tycon env evdref lvar c in
 			error_cant_apply_not_functional_loc 
-			  (join_loc floc argloc) env (evars_of !isevars)
+			  (join_loc floc argloc) env (evars_of !evdref)
 	      		  resj [hj]
 	in
 	let resj = apply_rec env 1 fj args in
 	let resj =
-	  match evar_kind_of_term !isevars resj.uj_val with
+	  match evar_kind_of_term !evdref resj.uj_val with
 	  | App (f,args) ->
-              let f = whd_evar (Evd.evars_of !isevars) f in
+              let f = whd_evar (Evd.evars_of !evdref) f in
               begin match kind_of_term f with
-              | Ind _ (* | Const _ *) ->
-	          let sigma = evars_of !isevars in
+              | Ind _ | Const _
+		  when isInd f or has_polymorphic_type (destConst f)
+		    ->
+	          let sigma = evars_of !evdref in
 		  let c = mkApp (f,Array.map (whd_evar sigma) args) in
 	          let t = Retyping.get_type_of env sigma c in
 		  make_judge c t
               | _ -> resj end
 	  | _ -> resj in
-	inh_conv_coerce_to_tycon loc env isevars resj tycon
+	inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RLambda(loc,name,c1,c2)      ->
-	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
+    | RLambda(loc,name,bk,c1,c2)      ->
+	let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon in
 	let dom_valcon = valcon_of_tycon dom in
-	let j = pretype_type dom_valcon env isevars lvar c1 in
+	let j = pretype_type dom_valcon env evdref lvar c1 in
 	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
-	  judge_of_abstraction env name j j'
+	let j' = pretype rng (push_rel var env) evdref lvar c2 in 
+	  judge_of_abstraction env (orelse_name name name') j j'
 
-    | RProd(loc,name,c1,c2)        ->
-	let j = pretype_type empty_valcon env isevars lvar c1 in
+    | RProd(loc,name,bk,c1,c2)        ->
+	let j = pretype_type empty_valcon env evdref lvar c1 in
 	let var = (name,j.utj_val) in
 	let env' = push_rel_assum var env in
-	let j' = pretype_type empty_valcon env' isevars lvar c2 in
+	let j' = pretype_type empty_valcon env' evdref lvar c2 in
 	let resj =
 	  try judge_of_product env name j j'
 	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 	    
     | RLetIn(loc,name,c1,c2)      ->
-	let j = pretype empty_tycon env isevars lvar c1 in
+	let j = pretype empty_tycon env evdref lvar c1 in
 	let t = refresh_universes j.uj_type in
 	let var = (name,Some j.uj_val,t) in
         let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
 	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
 	    uj_type = subst1 j.uj_val j'.uj_type }
 
     | RLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env isevars lvar c in
+	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  try find_rectype env (evars_of !evdref) cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj 
+	      error_case_not_inductive_loc cloc env (evars_of !evdref) cj 
 	in
 	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 1 then
@@ -459,50 +478,50 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	      (match po with
 		 | Some p ->
 		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p isevars lvar p in
-		     let ccl = nf_isevar !isevars pj.utj_val in
+		     let pj = pretype_type empty_valcon env_p evdref lvar p in
+		     let ccl = nf_isevar !evdref pj.utj_val in
 		     let psign = make_arity_signature env true indf in (* with names *)
 		     let p = it_mkLambda_or_LetIn ccl psign in
 		     let inst = 
 		       (Array.to_list cs.cs_concl_realargs)
 		       @[build_dependent_constructor cs] in
 		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env (evars_of !isevars) lp inst in
-		     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
+		     let fty = hnf_lam_applist env (evars_of !evdref) lp inst in
+		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
-		       let ci = make_default_case_info env LetStyle mis in
+		       let ci = make_case_info env mis LetStyle in
 			 mkCase (ci, p, cj.uj_val,[|f|]) in 
 		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
 
 		 | None -> 
 		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f isevars lvar d in
+		     let fj = pretype tycon env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_isevar !isevars fj.uj_type in
+		     let ccl = nf_isevar !evdref fj.uj_type in
 		     let ccl =
 		       if noccur_between 1 cs.cs_nargs ccl then
 			 lift (- cs.cs_nargs) ccl 
 		       else
-			 error_cant_find_case_type_loc loc env (evars_of !isevars) 
+			 error_cant_find_case_type_loc loc env (evars_of !evdref) 
 			   cj.uj_val in
 		     let ccl = refresh_universes ccl in
 		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
-		       let ci = make_default_case_info env LetStyle mis in
+		       let ci = make_case_info env mis LetStyle in
 			 mkCase (ci, p, cj.uj_val,[|f|] ) 
 		     in
 		       { uj_val = v; uj_type = ccl })
 
     | RIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env isevars lvar c in
+	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  try find_rectype env (evars_of !evdref) cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
+	      error_case_not_inductive_loc cloc env (evars_of !evdref) cj in
 	let cstrs = get_constructors env indf in 
 	  if Array.length cstrs <> 2 then
             user_err_loc (loc,"",
@@ -520,11 +539,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  let pred,p = match po with
 	    | Some p ->
 		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p isevars lvar p in
-		let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		let pj = pretype_type empty_valcon env_p evdref lvar p in
+		let ccl = nf_evar (evars_of !evdref) pj.utj_val in
 		let pred = it_mkLambda_or_LetIn ccl psign in
 		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
+		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
 								     uj_type = typ} tycon 
 		in
 		  jtyp.uj_val, jtyp.uj_type
@@ -532,11 +551,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		let p = match tycon with
 		  | Some (None, ty) -> ty
 		  | None | Some _ ->
-                      e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
+                      e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
 		in
 		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar (evars_of !isevars) pred in
-	  let p = nf_evar (evars_of !isevars) p in
+	  let pred = nf_evar (evars_of !evdref) pred in
+	  let p = nf_evar (evars_of !evdref) p in
 	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
 	  let f cs b =
 	    let n = rel_context_length cs.cs_args in
@@ -555,118 +574,129 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	    in
 	    let env_c = push_rels csgn env in 
 (* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
-	    let bj = pretype (mk_tycon pi) env_c isevars lvar b in
+	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
 	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
 	  let b1 = f cstrs.(0) b1 in
 	  let b2 = f cstrs.(1) b2 in
 	  let v =
 	    let mis,_ = dest_ind_family indf in
-	    let ci = make_default_case_info env IfStyle mis in
+	    let ci = make_case_info env mis IfStyle in
 	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
 	  in
 	    { uj_val = v; uj_type = p }
-
-    | RCases (loc,po,tml,eqns) ->
-	Cases.compile_cases loc
-	  ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+	
+    | RCases (loc,sty,po,tml,eqns) ->
+	Cases.compile_cases loc sty
+	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
 	  tycon env (* loc *) (po,tml,eqns)
 
     | RCast (loc,c,k) ->
 	let cj =
 	  match k with
 	      CastCoerce ->
-		let cj = pretype empty_tycon env isevars lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj
+		let cj = pretype empty_tycon env evdref lvar c in
+		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
 	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env isevars lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+		let tj = pretype_type empty_valcon env evdref lvar t in
+		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
 		  (* User Casts are for helping pretyping, experimentally not to be kept*)
 		  (* ... except for Correctness *)
 		let v = mkCast (cj.uj_val, k, tj.utj_val) in
 		  { uj_val = v; uj_type = tj.utj_val }
 	in
-	  inh_conv_coerce_to_tycon loc env isevars cj tycon
+	  inh_conv_coerce_to_tycon loc env evdref cj tycon
 
     | RDynamic (loc,d) ->
 	if (tag d) = "constr" then
 	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	  let j = (Retyping.get_judgment_of env (evars_of !evdref) c) in
 	    j
-	      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
+	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
 	else
 	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
 
-  (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
-  and pretype_type valcon env isevars lvar = function
+  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
+  and pretype_type valcon env evdref lvar = function
     | RHole loc ->
 	(match valcon with
 	   | Some v ->
                let s =
-		 let sigma = evars_of !isevars in
+		 let sigma = evars_of !evdref in
 		 let t = Retyping.get_type_of env sigma v in
 		   match kind_of_term (whd_betadeltaiota env sigma t) with
                      | Sort s -> s
-                     | Evar v when is_Type (existential_type sigma v) -> 
-			 evd_comb1 (define_evar_as_sort) isevars v
+                     | Evar ev when is_Type (existential_type sigma ev) -> 
+			 evd_comb1 (define_evar_as_sort) evdref ev
                      | _ -> anomaly "Found a type constraint which is not a type"
                in
 		 { utj_val = v;
 		   utj_type = s }
 	   | None ->
 	       let s = new_Type_sort () in
-		 { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
+		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
 		   utj_type = s})
     | c ->
-	let j = pretype empty_tycon env isevars lvar c in
+	let j = pretype empty_tycon env evdref lvar c in
 	let loc = loc_of_rawconstr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
+	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
 	  match valcon with
 	    | None -> tj
 	    | Some v ->
-		if e_cumul env isevars v tj.utj_val then tj
+		if e_cumul env evdref v tj.utj_val then tj
 		else
 		  error_unexpected_type_loc
-                    (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
+                    (loc_of_rawconstr c) env (evars_of !evdref) tj.utj_val v
 
-  let pretype_gen isevars env lvar kind c =
+  let pretype_gen_aux evdref env lvar kind c =
     let c' = match kind with
       | OfType exptyp ->
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	    (pretype tycon env isevars lvar c).uj_val
+	    (pretype tycon env evdref lvar c).uj_val
       | IsType ->
-	  (pretype_type empty_valcon env isevars lvar c).utj_val in
-      nf_evar (evars_of !isevars) c'
-
+	  (pretype_type empty_valcon env evdref lvar c).utj_val in
+    let evd,_ = consider_remaining_unif_problems env !evdref in
+      evdref := evd; c'
+	
+  let pretype_gen evdref env lvar kind c =
+    let c = pretype_gen_aux evdref env lvar kind c in
+      evdref := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !evdref;
+      nf_evar (evars_of !evdref) c
+	
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
      retourne aussi le nouveau sigma...
   *)
 
   let understand_judgment sigma env c =
-    let isevars = ref (create_evar_defs sigma) in
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let isevars,_ = consider_remaining_unif_problems env !isevars in
-    let j = j_nf_evar (evars_of isevars) j in
-      check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-      j
-
-  let understand_judgment_tcc isevars env c =
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let sigma = evars_of !isevars in
+    let evdref = ref (create_evar_defs sigma) in
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    let evd,_ = consider_remaining_unif_problems env !evdref in
+    let j = j_nf_evar (evars_of evd) j in
+    let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env evd in
+    let j = j_nf_evar (evars_of evd) j in
+    check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+    j
+
+  let understand_judgment_tcc evdref env c =
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    let sigma = evars_of !evdref in
     let j = j_nf_evar sigma j in
-      j
+    j
 
   (* Raw calls to the unsafe inference machine: boolean says if we must
      fail on unresolved evars; the unsafe_judgment list allows us to
      extend env with some bindings *)
 
   let ise_pretype_gen fail_evar sigma env lvar kind c =
-    let isevars = ref (Evd.create_evar_defs sigma) in
-    let c = pretype_gen isevars env lvar kind c in
-    let isevars,_ = consider_remaining_unif_problems env !isevars in
-    let c = nf_evar (evars_of isevars) c in
-      if fail_evar then check_evars env sigma isevars c;
-      isevars, c
+    let evdref = ref (Evd.create_evar_defs sigma) in
+    let c = pretype_gen evdref env lvar kind c in
+    let evd,_ = consider_remaining_unif_problems env !evdref in
+      if fail_evar then 
+	let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in
+	let c = Evarutil.nf_isevar evd c in
+	  check_evars env Evd.empty evd c;
+	  evd, c
+      else evd, c
 
   (** Entry points of the high-level type synthesis algorithm *)
 
@@ -682,12 +712,19 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   let understand_ltac sigma env lvar kind c =
     ise_pretype_gen false sigma env lvar kind c
       
-  let understand_tcc_evars isevars env kind c =
-    pretype_gen isevars env ([],[]) kind c
-
-  let understand_tcc sigma env ?expected_type:exptyp c =
-    let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
-      Evd.evars_of ev, t
+  let understand_tcc_evars evdref env kind c =
+    pretype_gen evdref env ([],[]) kind c
+
+  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
+    let evd, t =
+      if resolve_classes then
+	ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c 
+      else
+	let evdref = ref (Evd.create_evar_defs sigma) in
+	let c = pretype_gen_aux evdref env ([],[]) (OfType exptyp) c in
+	  !evdref, nf_isevar !evdref c
+    in
+    Evd.evars_of evd, t
 end
 
 module Default : S = Pretyping_F(Coercion.Default)
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index b1ed20c2..4f116053 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretyping.mli 9141 2006-09-15 10:07:01Z herbelin $ i*)
+(*i $Id: pretyping.mli 11047 2008-06-03 23:08:00Z msozeau $ i*)
 
 (*i*)
 open Names
@@ -18,6 +18,11 @@ open Rawterm
 open Evarutil
 (*i*)
 
+(* An auxiliary function for searching for fixpoint guard indexes *)
+
+val search_guard : 
+    Util.loc -> env -> int list list -> rec_declaration -> int array
+
 type typing_constraint = OfType of types option | IsType
 
 type var_map = (identifier * unsafe_judgment) list
@@ -35,7 +40,7 @@ sig
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
   
-  val understand_tcc :
+  val understand_tcc : ?resolve_classes:bool ->
     evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
     
   val understand_tcc_evars :
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
index aaf9e63d..62798a45 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/rawterm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rawterm.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: rawterm.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 (*i*)
 open Util
@@ -36,6 +36,8 @@ type rawsort = RProp of Term.contents | RType of Univ.universe option
 
 type binder_kind = BProd | BLambda | BLetIn
 
+type binding_kind = Explicit | Implicit
+
 type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
 
 type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
@@ -57,10 +59,10 @@ type rawconstr =
   | REvar of loc * existential_key * rawconstr list option
   | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
   | RApp of loc * rawconstr * rawconstr list
-  | RLambda of loc * name * rawconstr * rawconstr
-  | RProd of loc * name * rawconstr * rawconstr
+  | RLambda of loc * name * binding_kind * rawconstr * rawconstr
+  | RProd of loc * name * binding_kind * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
-  | RCases of loc * rawconstr option * tomatch_tuple * cases_clauses
+  | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses
   | RLetTuple of loc * name list * (name * rawconstr option) * 
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
@@ -71,7 +73,7 @@ type rawconstr =
   | RCast of loc * rawconstr * rawconstr cast_type
   | RDynamic of loc * Dyn.t
 
-and rawdecl = name * rawconstr option * rawconstr
+and rawdecl = name * binding_kind * rawconstr option * rawconstr
 
 and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
 
@@ -82,10 +84,13 @@ and fix_kind =
 and predicate_pattern =
     name * (loc * inductive * int * name list) option
 
-and tomatch_tuple = (rawconstr * predicate_pattern) list
+and tomatch_tuple = (rawconstr * predicate_pattern)
+
+and tomatch_tuples = tomatch_tuple list
+
+and cases_clause = (loc * identifier list * cases_pattern list * rawconstr)
 
-and cases_clauses =
-    (loc * identifier list * cases_pattern list * rawconstr) list
+and cases_clauses = cases_clause list
 
 let cases_predicate_names tml =
   List.flatten (List.map (function
@@ -101,22 +106,22 @@ let cases_predicate_names tml =
 
    - boolean in POldCase means it is recursive
 i*)
-let map_rawdecl f (na,obd,ty) = (na,option_map f obd,f ty)
+let map_rawdecl f (na,k,obd,ty) = (na,k,Option.map f obd,f ty)
 
 let map_rawconstr f = function
   | RVar (loc,id) -> RVar (loc,id)
   | RApp (loc,g,args) -> RApp (loc,f g, List.map f args)
-  | RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c)
-  | RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c)
+  | RLambda (loc,na,bk,ty,c) -> RLambda (loc,na,bk,f ty,f c)
+  | RProd (loc,na,bk,ty,c) -> RProd (loc,na,bk,f ty,f c)
   | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c)
-  | RCases (loc,rtntypopt,tml,pl) ->
-      RCases (loc,option_map f rtntypopt,
+  | RCases (loc,sty,rtntypopt,tml,pl) ->
+      RCases (loc,sty,Option.map f rtntypopt,
         List.map (fun (tm,x) -> (f tm,x)) tml,
         List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl)
   | RLetTuple (loc,nal,(na,po),b,c) ->
-      RLetTuple (loc,nal,(na,option_map f po),f b,f c)
+      RLetTuple (loc,nal,(na,Option.map f po),f b,f c)
   | RIf (loc,c,(na,po),b1,b2) ->
-      RIf (loc,f c,(na,option_map f po),f b1,f b2)
+      RIf (loc,f c,(na,Option.map f po),f b1,f b2)
   | RRec (loc,fk,idl,bl,tyl,bv) ->
       RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl,
             Array.map f tyl,Array.map f bv)
@@ -149,7 +154,7 @@ let map_rawconstr_with_binders_loc loc g f e = function
       let g' id e = snd (g id e) in
       let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in
       RCases
-	(loc,option_map (f e) tyopt,List.map (f e) tml, List.map h pl)
+	(loc,Option.map (f e) tyopt,List.map (f e) tml, List.map h pl)
   | RRec (_,fk,idl,tyl,bv) ->
       let idl',e' = fold_ident g idl e in
       RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
@@ -166,10 +171,10 @@ let occur_rawconstr id =
   let rec occur = function
     | RVar (loc,id') -> id = id'
     | RApp (loc,f,args) -> (occur f) or (List.exists occur args)
-    | RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
-    | RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
+    | RLambda (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
+    | RProd (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
     | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
-    | RCases (loc,rtntypopt,tml,pl) ->
+    | RCases (loc,sty,rtntypopt,tml,pl) ->
 	(occur_option rtntypopt)
         or (List.exists (fun (tm,_) -> occur tm) tml)
 	or (List.exists occur_pattern pl)
@@ -182,7 +187,7 @@ let occur_rawconstr id =
         not (array_for_all4 (fun fid bl ty bd ->
           let rec occur_fix = function
               [] -> not (occur ty) && (fid=id or not(occur bd))
-            | (na,bbd,bty)::bl ->
+            | (na,k,bbd,bty)::bl ->
                 not (occur bty) &&
                 (match bbd with
                     Some bd -> not (occur bd)
@@ -211,11 +216,11 @@ let free_rawvars  =
   let rec vars bounded vs = function
     | RVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs
     | RApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
-    | RLambda (loc,na,ty,c) | RProd (loc,na,ty,c) | RLetIn (loc,na,ty,c) -> 
+    | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> 
 	let vs' = vars bounded vs ty in 
 	let bounded' = add_name_to_ids bounded na in 
 	vars bounded' vs' c
-    | RCases (loc,rtntypopt,tml,pl) ->
+    | RCases (loc,sty,rtntypopt,tml,pl) ->
 	let vs1 = vars_option bounded vs rtntypopt in 
 	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in 
 	List.fold_left (vars_pattern bounded) vs2 pl
@@ -234,7 +239,7 @@ let free_rawvars  =
 	let vars_fix i vs fid = 
 	  let vs1,bounded1 = 
 	    List.fold_left 
-	      (fun (vs,bounded) (na,bbd,bty) -> 
+	      (fun (vs,bounded) (na,k,bbd,bty) -> 
 		 let vs' = vars_option bounded vs bbd in 
 		 let vs'' = vars bounded vs' bty in
 		 let bounded' = add_name_to_ids bounded na in 
@@ -272,10 +277,10 @@ let loc_of_rawconstr = function
   | REvar (loc,_,_) -> loc
   | RPatVar (loc,_) -> loc
   | RApp (loc,_,_) -> loc
-  | RLambda (loc,_,_,_) -> loc
-  | RProd (loc,_,_,_) -> loc
+  | RLambda (loc,_,_,_,_) -> loc
+  | RProd (loc,_,_,_,_) -> loc
   | RLetIn (loc,_,_,_) -> loc
-  | RCases (loc,_,_,_) -> loc
+  | RCases (loc,_,_,_,_) -> loc
   | RLetTuple (loc,_,_,_,_) -> loc
   | RIf (loc,_,_,_,_) -> loc
   | RRec (loc,_,_,_,_,_) -> loc
@@ -330,7 +335,14 @@ let all_flags =
 
 type 'a or_var = ArgArg of 'a | ArgVar of identifier located
 
-type 'a with_occurrences = int or_var list * 'a
+type occurrences_expr = bool * int or_var list
+
+let all_occurrences_expr_but l = (false,l)
+let no_occurrences_expr_but l = (true,l)
+let all_occurrences_expr = (false,[])
+let no_occurrences_expr = (true,[])
+
+type 'a with_occurrences = occurrences_expr * 'a
 
 type ('a,'b) red_expr_gen =
   | Red of bool
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
index 546b36b0..2ba8022f 100644
--- a/pretyping/rawterm.mli
+++ b/pretyping/rawterm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rawterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
+(*i $Id: rawterm.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -40,6 +40,8 @@ type rawsort = RProp of Term.contents | RType of Univ.universe option
 
 type binder_kind = BProd | BLambda | BLetIn
 
+type binding_kind = Explicit | Implicit
+
 type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
 
 type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
@@ -61,10 +63,10 @@ type rawconstr =
   | REvar of loc * existential_key * rawconstr list option
   | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
   | RApp of loc * rawconstr * rawconstr list
-  | RLambda of loc * name * rawconstr * rawconstr
-  | RProd of loc * name * rawconstr * rawconstr
+  | RLambda of loc * name * binding_kind *  rawconstr * rawconstr
+  | RProd of loc * name * binding_kind * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
-  | RCases of loc * rawconstr option * tomatch_tuple * cases_clauses
+  | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses
   | RLetTuple of loc * name list * (name * rawconstr option) * 
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
@@ -75,7 +77,7 @@ type rawconstr =
   | RCast of loc * rawconstr * rawconstr cast_type
   | RDynamic of loc * Dyn.t
 
-and rawdecl = name * rawconstr option * rawconstr
+and rawdecl = name * binding_kind * rawconstr option * rawconstr
 
 and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
 
@@ -86,12 +88,15 @@ and fix_kind =
 and predicate_pattern =
     name * (loc * inductive * int * name list) option
 
-and tomatch_tuple = (rawconstr * predicate_pattern) list
+and tomatch_tuple = (rawconstr * predicate_pattern)
+
+and tomatch_tuples = tomatch_tuple list
+
+and cases_clause = (loc * identifier list * cases_pattern list * rawconstr)
 
-and cases_clauses =
-    (loc * identifier list * cases_pattern list * rawconstr) list
+and cases_clauses = cases_clause list
 
-val cases_predicate_names : tomatch_tuple -> name list
+val cases_predicate_names : tomatch_tuples -> name list
 
 (*i - if PRec (_, names, arities, bodies) is in env then arities are
    typed in env too and bodies are typed in env enriched by the
@@ -141,7 +146,14 @@ val all_flags : 'a raw_red_flag
 
 type 'a or_var = ArgArg of 'a | ArgVar of identifier located
 
-type 'a with_occurrences = int or_var list * 'a
+type occurrences_expr = bool * int or_var list
+
+val all_occurrences_expr_but : int or_var list -> occurrences_expr
+val no_occurrences_expr_but : int or_var list -> occurrences_expr
+val all_occurrences_expr : occurrences_expr
+val no_occurrences_expr : occurrences_expr
+
+type 'a with_occurrences = occurrences_expr * 'a
 
 type ('a,'b) red_expr_gen =
   | Red of bool
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 5bbaa207..bd73740f 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: recordops.ml 9166 2006-09-23 11:20:06Z herbelin $ *)
+(* $Id: recordops.ml 10577 2008-02-19 10:18:19Z corbinea $ *)
 
 open Util
 open Pp
@@ -40,15 +40,13 @@ type struc_typ = {
 let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
 let projection_table = ref Cmap.empty
 
-let option_fold_right f p e = match p with Some a -> f a e | None -> e
-
 let load_structure i (_,(ind,id,kl,projs)) =
   let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
   let struc =
     { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
   structure_table := Indmap.add ind struc !structure_table;
   projection_table := 
-    List.fold_right (option_fold_right (fun proj -> Cmap.add proj struc))
+    List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc))
       projs !projection_table
 
 let cache_structure o =
@@ -60,7 +58,7 @@ let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) =
    (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *)
    (* the first component of subst_con.                                   *)
    list_smartmap 
-     (option_smartmap (fun kn -> fst (subst_con subst kn)))
+     (Option.smartmap (fun kn -> fst (subst_con subst kn)))
     projs
   in
     if projs' == projs && kn' == kn then obj else
@@ -68,7 +66,7 @@ let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) =
 
 let discharge_structure (_,(ind,id,kl,projs)) =
   Some (Lib.discharge_inductive ind, id, kl,
-        List.map (option_map Lib.discharge_con) projs)
+        List.map (Option.map Lib.discharge_con) projs)
 
 let (inStruc,outStruc) =
   declare_object {(default_object "STRUCTURE") with 
@@ -117,12 +115,19 @@ that maps the pair (Li,ci) to the following data
 
 type obj_typ = {
   o_DEF : constr;
+  o_INJ : int;      (* position of trivial argument (negative= none) *)
   o_TABS : constr list;    (* ordered *)
   o_TPARAMS : constr list; (* ordered *)
   o_TCOMPS : constr list } (* ordered *)
 
+type cs_pattern =
+    Const_cs of global_reference
+  | Prod_cs
+  | Sort_cs of sorts_family
+  | Default_cs
+
 let object_table =
-  (ref [] : ((global_reference * global_reference) * obj_typ) list ref)
+  (ref [] : ((global_reference * cs_pattern) * obj_typ) list ref)
 
 let canonical_projections () = !object_table
 
@@ -130,14 +135,31 @@ let keep_true_projections projs kinds =
   map_succeed (function (p,true) -> p | _ -> failwith "")
     (List.combine projs kinds)
 
-(* Intended to always success *)
+let cs_pattern_of_constr t =
+  match kind_of_term t with
+      App (f,vargs) -> 
+	begin 
+	  try  Const_cs (global_of_constr f) , -1, Array.to_list vargs with
+	      _ -> raise Not_found 
+	end 
+    | Rel n -> Default_cs, pred n, []
+    | Prod (_,a,b) when not (dependent (mkRel 1) b) -> Prod_cs, -1, [a;pop b]
+    | Sort s -> Sort_cs (family_of_sort s), -1, []
+    | _ -> 
+	begin 
+	  try  Const_cs (global_of_constr t) , -1, [] with
+	      _ -> raise Not_found 
+	end 
+
+(* Intended to always succeed *)
 let compute_canonical_projections (con,ind) =
   let v = mkConst con in
   let c = Environ.constant_value (Global.env()) con in
   let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in
   let lt = List.rev (List.map snd lt) in
   let args = snd (decompose_app t) in
-  let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in
+  let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = 
+    lookup_structure ind in
   let params, projs = list_chop p args in
   let lpj = keep_true_projections lpj kl in
   let lps = List.combine lpj projs in
@@ -146,13 +168,16 @@ let compute_canonical_projections (con,ind) =
       (fun l (spopt,t) -> (* comp=components *)
 	 match spopt with
            | Some proji_sp ->
-	       let c, args = decompose_app t in
-	       (try (ConstRef proji_sp, global_of_constr c, args) :: l
-                with Not_found -> l)
+	       begin
+		 try 
+		   let patt, n , args = cs_pattern_of_constr t in
+		     ((ConstRef proji_sp, patt, n, args) :: l)
+		 with Not_found -> l 
+	       end
 	   | _ -> l)
       [] lps in
-  List.map (fun (refi,c,argj) ->
-    (refi,c),{o_DEF=v; o_TABS=lt; o_TPARAMS=params; o_TCOMPS=argj})
+  List.map (fun (refi,c,inj,argj) ->
+    (refi,c),{o_DEF=v; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_TCOMPS=argj})
     comp
 
 let open_canonical_structure i (_,o) =
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index 0a05aef6..7a7d941d 100755
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: recordops.mli 9082 2006-08-24 17:03:28Z herbelin $ i*)
+(*i $Id: recordops.mli 10577 2008-02-19 10:18:19Z corbinea $ i*)
 
 (*i*)
 open Names
@@ -36,13 +36,22 @@ val find_projection_nparams : global_reference -> int
 (*  the effective components of a structure and the projections of the  *)
 (*  structure *)
 
+type cs_pattern =
+    Const_cs of global_reference
+  | Prod_cs 
+  | Sort_cs of sorts_family
+  | Default_cs
+
 type obj_typ = {
   o_DEF : constr;
+  o_INJ : int;      (* position of trivial argument *)
   o_TABS : constr list;    (* ordered *)
   o_TPARAMS : constr list; (* ordered *)
   o_TCOMPS : constr list } (* ordered *)
-               
-val lookup_canonical_conversion : (global_reference * global_reference) -> obj_typ
+
+val cs_pattern_of_constr : constr -> cs_pattern * int * constr list
+ 
+val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ
 val declare_canonical_structure : global_reference -> unit
 val canonical_projections : unit -> 
-  ((global_reference * global_reference) * obj_typ) list
+  ((global_reference * cs_pattern) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 19f515d0..6fc30aae 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reductionops.ml 9106 2006-09-01 11:18:17Z herbelin $ *)
+(* $Id: reductionops.ml 11010 2008-05-28 15:25:19Z barras $ *)
 
 open Pp
 open Util
@@ -601,6 +601,9 @@ let fakey = Profile.declare_profile "fhnf_apply";;
 let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
 *)
 
+let is_transparent k =
+  Conv_oracle.get_strategy k <> Conv_oracle.Opaque
+
 (* Conversion utility functions *)
 
 type conversion_test = constraints -> constraints
@@ -611,26 +614,7 @@ let pb_equal = function
   | CUMUL -> CONV
   | CONV -> CONV
 
-let sort_cmp pb s0 s1 cuniv =
-  match (s0,s1) with
-    | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible
-    | (Prop c1, Type u)  ->
-        (match pb with
-            CUMUL -> cuniv
-          | _ -> raise NotConvertible)
-    | (Type u1, Type u2) ->
-	(match pb with
-           | CONV -> enforce_eq u1 u2 cuniv
-	   | CUMUL -> enforce_geq u2 u1 cuniv)
-    | (_, _) -> raise NotConvertible
-
-let base_sort_cmp pb s0 s1 =
-  match (s0,s1) with
-    | (Prop c1, Prop c2) -> c1 = c2
-    | (Prop c1, Type u)  -> pb = CUMUL
-    | (Type u1, Type u2) -> true
-    | (_, _) -> false
-
+let sort_cmp = sort_cmp
 
 let test_conversion f env sigma x y =
   try let _ = f env (nf_evar sigma x) (nf_evar sigma y) in true
@@ -640,6 +624,14 @@ let is_conv env sigma = test_conversion Reduction.conv env sigma
 let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
 let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
 
+let test_trans_conversion f reds env sigma x y =
+  try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true
+  with NotConvertible -> false
+
+let is_trans_conv env sigma = test_trans_conversion Reduction.trans_conv env sigma
+let is_trans_conv_leq env sigma = test_trans_conversion Reduction.trans_conv_leq env sigma
+let is_trans_fconv = function | CONV -> is_trans_conv | CUMUL -> is_trans_conv_leq
+
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
@@ -675,10 +667,42 @@ let plain_instance s c =
   in 
   if s = [] then c else irec c
 
-(* Pourquoi ne fait-on pas nf_betaiota si s=[] ? *)
-let instance s c = 
-  if s = [] then c else local_strong whd_betaiota (plain_instance s c)
-
+(* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota]
+   has (unfortunately) different subtle side effects: 
+
+   - ** Order of subgoals **
+     If the lemma is a case analysis with parameters, it will move the
+     parameters as first subgoals (e.g. "case H" applied on
+     "H:D->A/\B|-C" will present the subgoal |-D first while w/o
+     betaiota the subgoal |-D would have come last).
+
+   - ** Betaiota-contraction in statement **
+     If the lemma has a parameter which is a function and this
+     function is applied in the lemma, then the _strong_ betaiota will
+     contract the application of the function to its argument (e.g.
+     "apply (H (fun x => x))" in "H:forall f, f 0 = 0 |- 0=0" will
+     result in applying the lemma 0=0 in which "(fun x => x) 0" has
+     been contracted). A goal to rewrite may then fail or succeed
+     differently.
+
+   - ** Naming of hypotheses ** 
+     If a lemma is a function of the form "fun H:(forall a:A, P a)
+     => .. F H .." where the expected type of H is "forall b:A, P b",
+     then, without reduction, the application of the lemma will
+     generate a subgoal "forall a:A, P a" (and intro will use name
+     "a"), while with reduction, it will generate a subgoal "forall
+     b:A, P b" (and intro will use name "b").
+
+   - ** First-order pattern-matching **
+     If a lemma has the type "(fun x => p) t" then rewriting t may fail
+     if the type of the lemma is first beta-reduced (this typically happens
+     when rewriting a single variable and the type of the lemma is obtained
+     by meta_instance (with empty map) which itself call instance with this
+     empty map.
+ *)
+
+let instance s c =
+  (* if s = [] then c else *) local_strong whd_betaiota (plain_instance s c)
 
 (* pseudo-reduction rule:
  * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
@@ -777,21 +801,23 @@ let is_sort env sigma arity =
 (* reduction to head-normal-form allowing delta/zeta only in argument
    of case/fix (heuristic used by evar_conv) *)
 
-let rec apprec env sigma s =
-  let (t, stack as s) = whd_betaiota_state s in
-  match kind_of_term t with
+let whd_betaiota_deltazeta_for_iota_state env sigma s =
+  let rec whrec s = 
+    let (t, stack as s) = whd_betaiota_state s in
+    match kind_of_term t with
     | Case (ci,p,d,lf) ->
         let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
         let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
         if reducible_mind_case cr then 
-	  apprec env sigma (rslt, stack)
+	  whrec (rslt, stack)
         else 
 	  s
     | Fix fix ->
 	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with
-             | Reduced s -> apprec env sigma s
+             | Reduced s -> whrec s
 	     | NotReducible -> s)
     | _ -> s
+  in whrec s
 
 (* A reduction function like whd_betaiota but which keeps casts
  * and does not reduce redexes containing existential variables.
@@ -861,13 +887,12 @@ let is_arity env sigma c =
 
 let meta_value evd mv = 
   let rec valrec mv =
-    try
-      let b = meta_fvalue evd mv in
+    match meta_opt_fvalue evd mv with
+    | Some (b,_) -> 
       instance
         (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
         b.rebus
-    with Anomaly _ | Not_found -> 
-      mkMeta mv
+    | None -> mkMeta mv
   in 
   valrec mv
 
@@ -876,6 +901,55 @@ let meta_instance env b =
     List.map 
       (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
   in 
-  instance c_sigma b.rebus
+  if c_sigma = [] then b.rebus else instance c_sigma b.rebus
 
 let nf_meta env c = meta_instance env (mk_freelisted c)
+
+(* Instantiate metas that create beta/iota redexes *)
+
+let meta_value evd mv = 
+  let rec valrec mv =
+    match meta_opt_fvalue evd mv with
+    | Some (b,_) ->
+      instance
+        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
+        b.rebus
+    | None -> mkMeta mv
+  in 
+  valrec mv
+
+let meta_reducible_instance evd b =
+  let fm = Metaset.elements b.freemetas in
+  let metas = List.fold_left (fun l mv -> 
+    match (try meta_opt_fvalue evd mv with Not_found -> None) with
+    | Some (g,(_,s)) -> (mv,(g.rebus,s))::l 
+    | None -> l) [] fm in
+  let rec irec u =
+    let u = whd_betaiota u in
+    match kind_of_term u with
+    | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) ->
+	let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in
+	(match
+	  try
+	    let g,s = List.assoc m metas in
+	    if isConstruct g or s <> CoerceToType then Some g else None
+	  with Not_found -> None
+	  with
+	    | Some g -> irec (mkCase (ci,p,g,bl))
+	    | None -> mkCase (ci,irec p,c,Array.map irec bl))
+    | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) ->
+	let m = try destMeta f with _ -> destMeta (pi1 (destCast f)) in
+	(match
+	  try
+	    let g,s = List.assoc m metas in
+	    if isLambda g or s <> CoerceToType then Some g else None
+	  with Not_found -> None
+	 with
+	   | Some g -> irec (mkApp (g,l))
+	   | None -> mkApp (f,Array.map irec l))
+    | Meta m ->
+	(try let g,s = List.assoc m metas in if s<>CoerceToType then irec g else u
+	 with Not_found -> u)
+    | _ -> map_constr irec u
+  in 
+  if fm = [] then (* nf_betaiota? *) b.rebus else irec b.rebus
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 1e9b3b5b..d48055cf 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reductionops.mli 9106 2006-09-01 11:18:17Z herbelin $ i*)
+(*i $Id: reductionops.mli 11010 2008-05-28 15:25:19Z barras $ i*)
 
 (*i*)
 open Names
@@ -181,7 +181,8 @@ val is_arity : env ->  evar_map -> constr -> bool
 
 val whd_programs :  reduction_function
 
-(* [reduce_fix] contracts a fix redex if it is actually reducible *)
+(* [reduce_fix redfun fix stk] contracts [fix stk] if it is actually
+   reducible; the structural argument is reduced by [redfun] *)
 
 type fix_reduction_result = NotReducible | Reduced of state
 
@@ -189,6 +190,9 @@ val fix_recarg : fixpoint -> constr stack -> (int * constr) option
 val reduce_fix : local_state_reduction_function -> fixpoint
    -> constr stack -> fix_reduction_result
 
+(*s Querying the kernel conversion oracle: opaque/transparent constants *)
+val is_transparent : 'a tableKey -> bool
+
 (*s Conversion Functions (uses closures, lazy strategy) *)
 
 type conversion_test = constraints -> constraints
@@ -197,12 +201,15 @@ val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
 val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test
-val base_sort_cmp : conv_pb -> sorts -> sorts -> bool
 
 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
+
 (*s Special-Purpose Reduction Functions *)
 
 val whd_meta : (metavariable * constr) list -> constr -> constr
@@ -211,8 +218,9 @@ val instance : (metavariable * constr) list -> constr -> constr
 
 (*s Heuristic for Conversion with Evar *)
 
-val apprec :  state_reduction_function
+val whd_betaiota_deltazeta_for_iota_state :  state_reduction_function
 
 (*s Meta-related reduction functions *)
 val meta_instance : evar_defs -> constr freelisted -> constr
 val nf_meta       : evar_defs -> constr -> constr
+val meta_reducible_instance : evar_defs -> constr freelisted -> constr
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index ecead438..82c2668c 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retyping.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
+(* $Id: retyping.ml 11077 2008-06-09 11:26:32Z herbelin $ *)
 
 open Util
 open Term
@@ -44,7 +44,7 @@ let type_of_var env id =
   with Not_found ->
     anomaly ("type_of: variable "^(string_of_id id)^" unbound")
 
-let typeur sigma metamap =
+let retype sigma metamap =
   let rec type_of env cstr=
     match kind_of_term cstr with
     | Meta n ->
@@ -84,7 +84,7 @@ let typeur sigma metamap =
   and sort_of env t = 
     match kind_of_term t with
     | Cast (c,_, s) when isSort s -> destSort s
-    | Sort (Prop c) -> type_0
+    | 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
@@ -92,10 +92,12 @@ let typeur sigma metamap =
           | Prop _, (Prop Pos as s) -> s
           | Type _, (Prop Pos as s) when
               Environ.engagement env = Some ImpredicativeSet -> s
-          | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.base_univ)
-	  | Prop Pos, (Type u2) -> Type (Univ.sup Univ.base_univ u2)
+	  | (Type _, _) | (_, Type _) -> new_Type_sort ()
+(*
+          | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ)
+	  | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2)
 	  | Prop Null, (Type _ as s) -> s
-	  | Type u1, Type u2 -> Type (Univ.sup u1 u2))
+	  | Type u1, Type u2 -> Type (Univ.sup u1 u2)*))
     | App(f,args) when isGlobalRef f ->
 	let t = type_of_global_reference_knowing_parameters env f args in
         sort_of_atomic_type env sigma t args
@@ -132,14 +134,18 @@ let typeur sigma metamap =
   in type_of, sort_of, sort_family_of,
      type_of_global_reference_knowing_parameters
 
-let get_type_of env sigma c = let f,_,_,_ = typeur sigma [] in f env c
-let get_sort_of env sigma t = let _,f,_,_ = typeur sigma [] in f env t
-let get_sort_family_of env sigma c = let _,_,f,_ = typeur sigma [] in f env c
+let get_sort_of env sigma t = let _,f,_,_ = retype sigma [] in f env t
+let get_sort_family_of env sigma c = let _,_,f,_ = retype sigma [] in f env c
 let type_of_global_reference_knowing_parameters env sigma c args =
-  let _,_,_,f = typeur sigma [] in f env c args
+  let _,_,_,f = retype sigma [] in f env c args
 
-let get_type_of_with_meta env sigma metamap = 
-  let f,_,_,_ = typeur sigma metamap in f env
+(* We are outside the kernel: we take fresh universes *)
+(* to avoid tactics and co to refresh universes themselves *)
+let get_type_of env sigma c =
+  let f,_,_,_ = retype sigma [] in refresh_universes (f env c)
+
+let get_type_of_with_meta env sigma metamap c =
+  let f,_,_,_ = retype sigma metamap in refresh_universes (f env c)
 
 (* Makes an assumption from a constr *)
 let get_assumption_of env evc c = c
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 64e9ebec..50401502 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacred.ml 10135 2007-09-21 14:28:12Z herbelin $ *)
+(* $Id: tacred.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Pp
 open Util
@@ -35,18 +35,23 @@ exception ReductionTacticError of reduction_tactic_error
 exception Elimconst
 exception Redelimination
 
-let is_evaluable env ref =
-  match ref with
-      EvalConstRef kn ->
-        let (ids,kns) = Conv_oracle.freeze() in
-        Cpred.mem kn kns &
-        let cb = Environ.lookup_constant kn env in
-        cb.const_body <> None & not cb.const_opaque
-    | EvalVarRef id ->
-        let (ids,sps) = Conv_oracle.freeze() in
-        Idpred.mem id ids &
-        let (_,value,_) = Environ.lookup_named id env in
-        value <> None
+let is_evaluable env = function
+  | EvalConstRef kn ->
+      is_transparent (ConstKey kn) &&
+      let cb = Environ.lookup_constant kn env in
+      cb.const_body <> None & not cb.const_opaque
+  | EvalVarRef id ->
+      is_transparent (VarKey id) &&
+      let (_,value,_) = Environ.lookup_named id env in
+      value <> None
+
+let value_of_evaluable_ref env = function
+  | EvalConstRef con -> constant_value env con
+  | EvalVarRef id -> Option.get (pi2 (lookup_named id env))
+
+let constr_of_evaluable_ref = function
+  | EvalConstRef con -> mkConst con
+  | EvalVarRef id -> mkVar id
 
 type evaluable_reference =
   | EvalConst of constant
@@ -80,7 +85,7 @@ let reference_opt_value sigma env = function
       v
   | EvalRel n ->
       let (_,v,_) = lookup_rel n env in
-      option_map (lift n) v
+      Option.map (lift n) v
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 exception NotEvaluable
@@ -90,8 +95,8 @@ let reference_value sigma env c =
     | Some d -> d
 
 (************************************************************************)
-(* Reduction of constant hiding fixpoints (e.g. for Simpl). The trick   *)
-(* is to reuse the name of the function after reduction of the fixpoint *)
+(* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic).  *)
+(* One reuses the name of the function after reduction of the fixpoint  *)
 
 type constant_evaluation = 
   | EliminationFix of int * (int * (int * constr) list * int)
@@ -103,7 +108,6 @@ type constant_evaluation =
 
 (* We use a cache registered as a global table *)
 
-
 module CstOrdered =
   struct
     type t = constant
@@ -325,20 +329,18 @@ let make_elim_fun (names,(nbfix,lv,n)) largs =
             list_fold_left_i (fun q (* j from comment is n+1-q *) c (ij,tij) ->
               let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in
               let tij' = substl (List.rev subst) tij in
-	      mkLambda (x,tij',c)
-            ) 1 body (List.rev lv)
+	      mkLambda (x,tij',c)) 1 body (List.rev lv)
           in Some g
 
-(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make 
-   the reduction using this extra information *)
+(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: 
+   do so that the reduction uses this extra information *)
 
 let contract_fix_use_function f
-  ((recindices,bodynum),(types,names,bodies as typedbodies)) =
+  ((recindices,bodynum),(_names,_types,bodies as typedbodies)) =
   let nbodies = Array.length recindices in
   let make_Fi j = match f j with
     | None -> mkFix((recindices,j),typedbodies)
     | Some c -> c in
-(*    match List.nth names j with Name id -> f id | _ -> assert false in*)
   let lbodies = list_tabulate make_Fi nbodies in
   substl (List.rev lbodies) bodies.(bodynum)
 
@@ -378,7 +380,7 @@ let reduce_mind_case_use_function func env mia =
 	    fun i ->
 	      if i = bodynum then Some func
 	      else match names.(i) with
-                | Anonymous -> None
+		| Anonymous -> None
 		| Name id ->
 		    (* In case of a call to another component of a block of 
 		       mutual inductive, try to reuse the global name if
@@ -419,20 +421,23 @@ let special_red_case sigma env whfun (ci, p, c, lf)  =
   in 
   redrec (c, empty_stack)
 
+(* [red_elim_const] contracts iota/fix/cofix redexes hidden behind
+   constants by keeping the name of the constants in the recursive calls;
+   it fails if no redex is around *)
 
 let rec red_elim_const env sigma ref largs =
   match reference_eval sigma env ref with
     | EliminationCases n when stack_args_size largs >= n ->
 	let c = reference_value sigma env ref in
 	let c', lrest = whd_betadelta_state env sigma (c,largs) in
-        (special_red_case sigma env (construct_const env sigma) (destCase c'),
-	 lrest)
+	let whfun = whd_simpl_state env sigma in
+        (special_red_case sigma env whfun (destCase c'), lrest)
     | EliminationFix (min,infos) when stack_args_size largs >=min ->
 	let c = reference_value sigma env ref in
 	let d, lrest = whd_betadelta_state env sigma (c,largs) in
 	let f = make_elim_fun ([|Some ref|],infos) largs in
-	let co = construct_const env sigma in
-	(match reduce_fix_use_function f co (destFix d) lrest with
+	let whfun = whd_construct_state env sigma in
+	(match reduce_fix_use_function f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
 	   | Reduced (c,rest) -> (nf_beta c, rest))
     | EliminationMutualFix (min,refgoal,refinfos)
@@ -447,53 +452,65 @@ let rec red_elim_const env sigma ref largs =
 	let (_, midargs as s) = descend ref largs in
 	let d, lrest = whd_betadelta_state env sigma s in
 	let f = make_elim_fun refinfos midargs in
-	let co = construct_const env sigma in
-	(match reduce_fix_use_function f co (destFix d) lrest with
+	let whfun = whd_construct_state env sigma in
+	(match reduce_fix_use_function f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
 	   | Reduced (c,rest) -> (nf_beta c, rest))
     | _ -> raise Redelimination
 
-and construct_const env sigma = 
-  let rec hnfstack (x, stack as s) =
+(* reduce to whd normal form or to an applied constant that does not hide
+   a reducible iota/fix/cofix redex (the "simpl" tactic) *)
+
+and whd_simpl_state env sigma s =
+  let rec redrec (x, stack as s) =
     match kind_of_term x with
-      | Cast (c,_,_) -> hnfstack (c, stack)
-      | App (f,cl) -> hnfstack (f, append_stack cl stack)
-      | Lambda (id,t,c) ->
+      | Lambda (na,t,c) ->
           (match decomp_stack stack with 
-             | None -> assert false
-             | Some (c',rest) -> 
-		   stacklam hnfstack [c'] c rest)
-      | LetIn (n,b,t,c) -> stacklam hnfstack [b] c stack
+             | None -> s
+             | Some (a,rest) -> stacklam redrec [a] c rest)
+      | LetIn (n,b,t,c) -> stacklam redrec [b] c stack
+      | App (f,cl) -> redrec (f, append_stack cl stack)
+      | Cast (c,_,_) -> redrec (c, stack)
       | Case (ci,p,c,lf) ->
-          hnfstack 
-	    (special_red_case sigma env
-              (construct_const env sigma) (ci,p,c,lf), stack)
-      | Construct _ -> s
-      | CoFix _ -> s
-      | Fix fix -> 
-	  (match reduce_fix hnfstack fix stack with
-             | Reduced s' -> hnfstack s'
-	     | NotReducible -> raise Redelimination)
+          (try 
+	    redrec (special_red_case sigma env redrec (ci,p,c,lf), stack)
+	  with
+	      Redelimination -> s)
+      | Fix fix ->
+	  (try match reduce_fix (whd_construct_state env sigma) fix stack with
+            | Reduced s' -> redrec s'
+	    | NotReducible -> s
+	  with Redelimination -> s)
       | _ when isEvalRef env x ->
 	  let ref = destEvalRef x in
           (try
-	    hnfstack (red_elim_const env sigma ref stack)
+	    redrec (red_elim_const env sigma ref stack)
            with Redelimination ->
-	     (match reference_opt_value sigma env ref with
-		| Some cval ->
-		    (match kind_of_term cval with
-                       | CoFix _ -> s
-                       | _ -> hnfstack (cval, stack))
-		| None ->
-		    raise Redelimination))
-      | _ -> raise Redelimination
+	     s)
+      | _ -> s
   in 
-  hnfstack 
+  redrec s
+
+(* reduce until finding an applied constructor or fail *)
+
+and whd_construct_state env sigma s =
+  let (constr, cargs as s') = whd_simpl_state env sigma s in 
+  if reducible_mind_case constr then s'
+  else if isEvalRef env constr then
+    let ref = destEvalRef constr in
+    match reference_opt_value sigma env ref with
+      | None -> raise Redelimination
+      | Some gvalue -> whd_construct_state env sigma (gvalue, cargs)
+  else
+    raise Redelimination
 
 (************************************************************************)
 (*            Special Purpose Reduction Strategies                     *)
 
-(* Red reduction tactic: reduction to a product *)
+(* Red reduction tactic: one step of delta reduction + full
+   beta-iota-fix-cofix-zeta-cast at the head of the conclusion of a
+   sequence of products; fails if no delta redex is around
+*)
 
 let try_red_product env sigma c = 
   let simpfun = clos_norm_flags betaiotazeta env sigma in
@@ -528,97 +545,105 @@ let red_product env sigma c =
   try try_red_product env sigma c
   with Redelimination -> error "Not reducible"
 
-let hnf_constr env sigma c = 
-  let rec redrec (x, largs as s) =
+(*
+(* This old version of hnf uses betadeltaiota instead of itself (resp 
+   whd_construct_state) to reduce the argument of Case (resp Fix);
+   The new version uses the "simpl" strategy instead. For instance,
+
+   Variable n:nat.
+   Eval hnf in match (plus (S n) O) with S n => n | _ => O end.  
+
+   returned
+
+   (fix plus (n m : nat) {struct n} : nat :=
+        match n with
+        | O => m
+        | S p => S (plus p m)
+        end) n 0
+
+   while the new version returns (plus n O)
+ *)
+
+let whd_simpl_orelse_delta_but_fix_old env sigma c =
+  let whd_all = whd_betadeltaiota_state env sigma in
+  let rec redrec (x, stack as s) =
     match kind_of_term x with
-      | Lambda (n,t,c) ->
-          (match decomp_stack largs with
-             | None      -> app_stack s
-             | Some (a,rest) -> 
-		 stacklam redrec [a] c rest)
-      | LetIn (n,b,t,c) -> stacklam redrec [b] c largs
-      | App (f,cl)   -> redrec (f, append_stack cl largs)
-      | Cast (c,_,_) -> redrec (c, largs)
-      | Case (ci,p,c,lf) ->
+      | Lambda (na,t,c) ->
+          (match decomp_stack stack with
+             | None      -> s
+             | Some (a,rest) -> stacklam redrec [a] c rest)
+      | LetIn (n,b,t,c) -> stacklam redrec [b] c stack
+      | App (f,cl)   -> redrec (f, append_stack cl stack)
+      | Cast (c,_,_) -> redrec (c, stack)
+      | Case (ci,p,d,lf) ->
           (try
-             redrec 
-	       (special_red_case sigma env (whd_betadeltaiota_state env sigma) 
-		  (ci, p, c, lf), largs)
+             redrec (special_red_case sigma env whd_all (ci,p,d,lf), stack)
            with Redelimination -> 
-	     app_stack s)
+	     s)
       | Fix fix ->
-	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
+	  (match reduce_fix whd_all fix stack with
              | Reduced s' -> redrec s'
-	     | NotReducible -> app_stack s)
+	     | NotReducible -> s)
       | _ when isEvalRef env x ->
 	  let ref = destEvalRef x in
           (try
-            let (c',lrest) = red_elim_const env sigma ref largs in 
-	    redrec (c', lrest)
+	    redrec (red_elim_const env sigma ref stack)
            with Redelimination ->
              match reference_opt_value sigma env ref with
 	       | Some c ->
 		   (match kind_of_term (snd (decompose_lam c)) with 
-                      | CoFix _ | Fix _ -> app_stack (x,largs)
-		      | _ -> redrec (c, largs))
-	       | None -> app_stack s)
-      | _ -> app_stack s
-  in 
-  redrec (c, empty_stack)
+                     | CoFix _ | Fix _ -> s
+		     | _ -> redrec (c, stack))
+	       | None -> s)
+      | _ -> s
+  in app_stack (redrec (c, empty_stack))
+*)
 
-(* Simpl reduction tactic: same as simplify, but also reduces
-   elimination constants *)
+(* Same as [whd_simpl] but also reduces constants that do not hide a
+   reducible fix, but does this reduction of constants only until it
+   it immediately hides a non reducible fix or a cofix *)
 
-let whd_nf env sigma c = 
-  let rec nf_app (c, stack as s) =
-    match kind_of_term c with
-      | Lambda (name,c1,c2)    ->
-          (match decomp_stack stack with
-             | None -> (c,empty_stack)
-             | Some (a1,rest) -> 
-		 stacklam nf_app [a1] c2 rest)
-      | LetIn (n,b,t,c) -> stacklam nf_app [b] c stack
-      | App (f,cl) -> nf_app (f, append_stack cl stack)
-      | Cast (c,_,_) -> nf_app (c, stack)
-      | Case (ci,p,d,lf) ->
-          (try
-             nf_app (special_red_case sigma env nf_app (ci,p,d,lf), stack)
-           with Redelimination -> 
-	     s)
-      | Fix fix ->
-	  (match reduce_fix nf_app fix stack with
-             | Reduced s' -> nf_app s'
-	     | NotReducible -> s)
-      | _ when isEvalRef env c ->
-          (try
-	     nf_app (red_elim_const env sigma (destEvalRef c) stack)
-           with Redelimination -> 
-	     s)
-      | _ -> s
-  in 
-  app_stack (nf_app (c, empty_stack))
+let whd_simpl_orelse_delta_but_fix env sigma c =
+  let rec redrec s =
+    let (constr, stack as s') = whd_simpl_state env sigma s in 
+    if isEvalRef env constr then
+      match reference_opt_value sigma env (destEvalRef constr) with
+	| Some c ->
+	    (match kind_of_term (snd (decompose_lam c)) with 
+              | CoFix _ | Fix _ -> s'
+	      | _ -> redrec (c, stack))
+	| None -> s'
+    else s'
+  in app_stack (redrec (c, empty_stack))
+
+let hnf_constr = whd_simpl_orelse_delta_but_fix
+
+(* The "simpl" reduction tactic *)
+
+let whd_simpl env sigma c =
+  app_stack (whd_simpl_state env sigma (c, empty_stack))
 
-let nf env sigma c = strong whd_nf env sigma c
+let simpl env sigma c = strong whd_simpl env sigma c
+
+let nf = simpl (* Compatibility *)
+
+(* Reduction at specific subterms *)
 
 let is_head c t =
   match kind_of_term t with
     | App (f,_) -> f = c
     | _ -> false
 
-let contextually byhead (locs,c) f env sigma t =
+let contextually byhead ((nowhere_except_in,locs),c) f env sigma t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref 1 in
-  let except = List.exists (fun n -> n<0) locs in
-  if except & (List.exists (fun n -> n>=0) locs) 
-  then error "mixing of positive and negative occurences"
-  else
-   let rec traverse (env,c as envc) t =
-    if locs <> [] & (not except) & (!pos > maxocc) then t
+  let rec traverse (env,c as envc) t =
+    if nowhere_except_in & (!pos > maxocc) then t
     else
     if (not byhead & eq_constr c t) or (byhead & is_head c t) then
       let ok = 
-	if except then not (List.mem (- !pos) locs)
-	else (locs = [] or List.mem !pos locs) in
+	if nowhere_except_in then List.mem !pos locs
+	else not (List.mem !pos locs) in
       incr pos;
       if ok then
 	f env sigma t
@@ -634,110 +659,34 @@ let contextually byhead (locs,c) f env sigma t =
         traverse envc t
   in
   let t' = traverse (env,c) t in
-  if locs <> [] & List.exists (fun o -> o >= !pos or o <= - !pos) locs then
-    error_invalid_occurrence locs;
+  if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
   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. *)
-let rec substlin env name n ol c =
-  match kind_of_term c with
-    | Const kn when EvalConstRef kn = name ->
-        if List.hd ol = n then
-          try 
-	    (n+1, List.tl ol, constant_value env kn)
-          with
-	      NotEvaluableConst _ ->
-		errorlabstrm "substlin"
-		  (pr_con kn ++ str " is not a defined constant")
-        else 
-	  ((n+1), ol, c)
-
-    | Var id when EvalVarRef id = name ->
-        if List.hd ol = n then
-          match lookup_named id env with
-	    | (_,Some c,_) -> (n+1, List.tl ol, c)
-	    | _ -> 
-		errorlabstrm "substlin"
-		  (pr_id id ++ str " is not a defined constant")
-        else 
-	  ((n+1), ol, c)
-
-    (* INEFFICIENT: OPTIMIZE *)
-    | App (c1,cl) ->
-        Array.fold_left 
-	  (fun (n1,ol1,c1') c2 ->
-	     (match ol1 with 
-                | [] -> (n1,[],applist(c1',[c2]))
-                | _  ->
-                    let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-                    (n2,ol2,applist(c1',[c2']))))
-          (substlin env name n ol c1) cl
-
-    | Lambda (na,c1,c2) ->
-        let (n1,ol1,c1') = substlin env name n ol c1 in
-        (match ol1 with 
-           | [] -> (n1,[],mkLambda (na,c1',c2))
-           | _  ->
-               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-               (n2,ol2,mkLambda (na,c1',c2')))
-
-    | LetIn (na,c1,t,c2) ->
-        let (n1,ol1,c1') = substlin env name n ol c1 in
-        (match ol1 with 
-           | [] -> (n1,[],mkLetIn (na,c1',t,c2))
-           | _  ->
-               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-               (n2,ol2,mkLetIn (na,c1',t,c2')))
-
-    | Prod (na,c1,c2) ->
-        let (n1,ol1,c1') = substlin env name n ol c1 in
-        (match ol1 with 
-           | [] -> (n1,[],mkProd (na,c1',c2))
-           | _  ->
-               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-               (n2,ol2,mkProd (na,c1',c2')))
-	
-    | Case (ci,p,d,llf) ->
-        let rec substlist nn oll = function
-          | []     -> (nn,oll,[])
-          | f::lfe ->
-              let (nn1,oll1,f') = substlin env name nn oll f in
-              (match oll1 with
-                 | [] -> (nn1,[],f'::lfe)
-                 | _  ->
-                     let (nn2,oll2,lfe') = substlist nn1 oll1 lfe in
-                     (nn2,oll2,f'::lfe'))
-	in
-	(* p is printed after d in v8 syntax *)
-	let (n1,ol1,d') = substlin env name n ol d in
-        (match ol1 with
-           | [] -> (n1,[],mkCase (ci, p, d', llf))
-           | _  ->
-               let (n2,ol2,p') = substlin env name n1 ol1 p in
-               (match ol2 with
-		  | [] -> (n2,[],mkCase (ci, p', d', llf))
-		  | _  -> 
-	              let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf)
-                      in (n3,ol3,mkCase (ci, p', d', Array.of_list lf'))))
-        
-    | Cast (c1,k,c2)   ->
-        let (n1,ol1,c1') = substlin env name n ol c1 in
-        (match ol1 with 
-           | [] -> (n1,[],mkCast (c1',k,c2))
-           | _  -> 
-	       let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-               (n2,ol2,mkCast (c1',k,c2')))
-
-    | Fix _ -> 
-        (warning "do not consider occurrences inside fixpoints"; (n,ol,c))
-	
-    | CoFix _ -> 
-        (warning "do not consider occurrences inside cofixpoints"; (n,ol,c))
 
-    | (Rel _|Meta _|Var _|Sort _
-      |Evar _|Const _|Ind _|Construct _) -> (n,ol,c)
+let substlin env evalref n (nowhere_except_in,locs) c =
+  let maxocc = List.fold_right max locs 0 in
+  let pos = ref n in
+  assert (List.for_all (fun x -> x >= 0) locs);
+  let value = value_of_evaluable_ref env evalref in
+  let term = constr_of_evaluable_ref evalref in
+  let rec substrec () c =
+    if nowhere_except_in & !pos > maxocc then c
+    else if c = term then
+      let ok = 
+	if nowhere_except_in then List.mem !pos locs
+	else not (List.mem !pos locs) in
+      incr pos;
+      if ok then value else c
+    else
+      map_constr_with_binders_left_to_right
+	(fun _ () -> ())
+        substrec () c
+  in
+  let t' = substrec () c in
+  (!pos, t')
 
 let string_of_evaluable_ref env = function
   | EvalVarRef id -> string_of_id id
@@ -755,16 +704,15 @@ let unfold env sigma name =
  * 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.
  * Performs a betaiota reduction after unfolding. *)
-let unfoldoccs env sigma (occl,name) c =
-  match occl with
-    | []  -> unfold env sigma name c
-    | l -> 
-        match substlin env name 1 (Sort.list (<) l) c with
-          | (_,[],uc) -> nf_betaiota uc
-          | (1,_,_) ->
-              error ((string_of_evaluable_ref env name)^" does not occur")
-          | (_,l,_) ->
-	      error_invalid_occurrence l
+let unfoldoccs env sigma ((nowhere_except_in,locs as plocs),name) c =
+  if locs = [] then if nowhere_except_in then c else unfold env sigma name c
+  else
+    let (nbocc,uc) = substlin env name 1 plocs c in
+    if nbocc = 1 then 
+      error ((string_of_evaluable_ref env name)^" does not occur");
+    let rest = List.filter (fun o -> o >= nbocc) locs in
+    if rest <> [] then error_invalid_occurrence rest;
+    nf_betaiota uc
 
 (* Unfold reduction tactic: *)
 let unfoldn loccname env sigma c = 
@@ -775,7 +723,17 @@ let fold_one_com com env sigma c =
   let rcom =
     try red_product env sigma com
     with Redelimination -> error "Not reducible" in
-  subst1 com (subst_term rcom c)
+  (* Reason first on the beta-iota-zeta normal form of the constant as
+     unfold produces it, so that the "unfold f; fold f" configuration works
+     to refold fix expressions *)
+  let a = subst_term (clos_norm_flags unfold_side_red env sigma rcom) c in
+  if not (eq_constr a c) then
+    subst1 com a
+  else
+    (* Then reason on the non beta-iota-zeta form for compatibility -
+       even if it is probably a useless configuration *)
+    let a = subst_term rcom c in
+    subst1 com a
 
 let fold_commands cl env sigma c =
   List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c
@@ -815,70 +773,81 @@ let pattern_occs loccs_trm env sigma c =
 
 (* Used in several tactics. *)
 
+(* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name
+   return name, B and t' *)
+
+let reduce_to_ind_gen allow_product env sigma t = 
+  let rec elimrec env t l =
+    let t = hnf_constr env sigma t in
+    match kind_of_term (fst (decompose_app t)) with
+      | Ind ind-> (ind, it_mkProd_or_LetIn t l)
+      | Prod (n,ty,t') ->
+	  if allow_product then
+	    elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
+	  else
+	    errorlabstrm "" (str"Not an inductive definition")
+      | _ ->
+	  (* Last chance: we allow to bypass the Opaque flag (as it
+	     was partially the case between V5.10 and V8.1 *)
+	  let t' = whd_betadeltaiota env sigma t in
+	  match kind_of_term (fst (decompose_app t')) with
+	    | Ind ind-> (ind, it_mkProd_or_LetIn t' l)
+	    | _ -> errorlabstrm "" (str"Not an inductive product")
+  in
+  elimrec env t []
+
+let reduce_to_quantified_ind x = reduce_to_ind_gen true x
+let reduce_to_atomic_ind x = reduce_to_ind_gen false x
+
+(* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta]
+   or raise [NotStepReducible] if not a weak-head redex *)
+
 exception NotStepReducible
 
 let one_step_reduce env sigma c = 
-  let rec redrec (x, largs) =
+  let rec redrec (x, stack) =
     match kind_of_term x with
       | Lambda (n,t,c)  ->
-          (match decomp_stack largs with
+          (match decomp_stack stack with
              | None      -> raise NotStepReducible
              | Some (a,rest) -> (subst1 a c, rest))
-      | App (f,cl) -> redrec (f, append_stack cl largs)
-      | LetIn (_,f,_,cl) -> (subst1 f cl,largs)
+      | App (f,cl) -> redrec (f, append_stack cl stack)
+      | LetIn (_,f,_,cl) -> (subst1 f cl,stack)
+      | Cast (c,_,_) -> redrec (c,stack)
       | Case (ci,p,c,lf) ->
           (try
-	     (special_red_case sigma env (whd_betadeltaiota_state env sigma)
-	       (ci,p,c,lf), largs)
+	     (special_red_case sigma env (whd_simpl_state env sigma)
+	       (ci,p,c,lf), stack)
            with Redelimination -> raise NotStepReducible)
       | Fix fix ->
-	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
+	  (match reduce_fix (whd_construct_state env sigma) fix stack with
              | Reduced s' -> s'
 	     | NotReducible -> raise NotStepReducible)
-      | Cast (c,_,_) -> redrec (c,largs)
       | _ when isEvalRef env x ->
-	  let ref =
-            try destEvalRef x
-            with Redelimination -> raise NotStepReducible in
+	  let ref = destEvalRef x in
           (try
-            red_elim_const env sigma ref largs
+            red_elim_const env sigma ref stack
            with Redelimination ->
 	     match reference_opt_value sigma env ref with
-	       | Some d -> d, largs
+	       | Some d -> d, stack
 	       | None -> raise NotStepReducible)
 
       | _ -> raise NotStepReducible
   in 
   app_stack (redrec (c, empty_stack))
 
-(* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name
-   return name, B and t' *)
+let isIndRef = function IndRef _ -> true | _ -> false
 
-let reduce_to_ind_gen allow_product env sigma t = 
-  let rec elimrec env t l = 
-    let c, _ = Reductionops.whd_stack t in
-    match kind_of_term c with
-      | Ind (mind,args) -> ((mind,args),it_mkProd_or_LetIn t l)
-      | Prod (n,ty,t') ->
-	  if allow_product then
-	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
-	  else
-	     errorlabstrm "tactics__reduce_to_mind"
-	       (str"Not an inductive definition")
-      | _ ->
-          (try 
-	     let t' = nf_betaiota (one_step_reduce env sigma t) in 
-	     elimrec env t' l
-           with NotStepReducible ->
-	     errorlabstrm "tactics__reduce_to_mind"
-               (str"Not an inductive product"))
-  in
-  elimrec env t []
-
-let reduce_to_quantified_ind x = reduce_to_ind_gen true x
-let reduce_to_atomic_ind x = reduce_to_ind_gen false x
-
-let reduce_to_ref_gen allow_product env sigma ref t = 
+let reduce_to_ref_gen allow_product env sigma ref t =
+  if isIndRef ref then
+    let (mind,t) = reduce_to_ind_gen allow_product env sigma t in
+    if IndRef mind <> ref then
+      errorlabstrm "" (str "Cannot recognize a statement based on " ++ 
+        Nametab.pr_global_env Idset.empty ref)
+    else
+      t
+  else
+  (* lazily reduces to match the head of [t] with the expected [ref] *)
   let rec elimrec env t l = 
     let c, _ = Reductionops.whd_stack t in
     match kind_of_term c with
@@ -886,8 +855,9 @@ let reduce_to_ref_gen allow_product env sigma ref t =
 	  if allow_product then
 	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
 	  else 
-	     errorlabstrm "Tactics.reduce_to_ref_gen"
-	       (str"Not an induction object of atomic type")
+	     errorlabstrm "" 
+	       (str "Cannot recognize an atomic statement based on " ++ 
+	        Nametab.pr_global_env Idset.empty ref)
       | _ ->
 	  try 
 	    if global_of_constr c = ref 
@@ -899,8 +869,8 @@ let reduce_to_ref_gen allow_product env sigma ref t =
 	    elimrec env t' l
           with NotStepReducible ->
 	    errorlabstrm ""
-	    (str "Not a statement of conclusion " ++ 
-	     Nametab.pr_global_env Idset.empty ref)
+	      (str "Cannot recognize a statement based on " ++ 
+	       Nametab.pr_global_env Idset.empty ref)
   in
   elimrec env t []
 
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 691fdf01..e12d6ad2 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacred.mli 8878 2006-05-30 16:44:25Z herbelin $ i*)
+(*i $Id: tacred.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -16,6 +16,7 @@ open Evd
 open Reductionops
 open Closure
 open Rawterm
+open Termops
 (*i*)
 
 type reduction_tactic_error = 
@@ -35,21 +36,25 @@ val red_product : reduction_function
 (* Red (raise Redelimination if nothing reducible) *)
 val try_red_product : reduction_function
 
-(* Hnf *)
-val hnf_constr :  reduction_function
-
 (* Simpl *)
-val nf :  reduction_function
+val simpl : reduction_function 
+
+(* Simpl only at the head *)
+val whd_simpl : reduction_function
+
+(* Hnf: like whd_simpl but force delta-reduction of constants that do
+   not immediately hide a non reducible fix or cofix *)
+val hnf_constr : reduction_function
 
 (* Unfold *)
 val unfoldn : 
-  (int list * evaluable_global_reference) list ->  reduction_function
+  (occurrences * evaluable_global_reference) list ->  reduction_function
 
 (* Fold *)
 val fold_commands : constr list ->  reduction_function
 
 (* Pattern *)
-val pattern_occs : (int list * constr) list ->  reduction_function
+val pattern_occs : (occurrences * constr) list ->  reduction_function
 (* Rem: Lazy strategies are defined in Reduction *)
 
 (* Call by value strategy (uses Closures) *)
@@ -77,5 +82,10 @@ val reduce_to_quantified_ref :
 val reduce_to_atomic_ref :
   env ->  evar_map -> Libnames.global_reference -> types -> types
 
-val contextually : bool -> int list * constr -> reduction_function
+val contextually : bool -> occurrences * constr -> reduction_function
   -> reduction_function
+
+(* Compatibility *)
+(* use [simpl] instead of [nf] *)
+val nf :  reduction_function
+
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 6b7e1fb7..e31024bb 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termops.ml 9429 2006-12-12 08:01:03Z herbelin $ *)
+(* $Id: termops.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -160,18 +160,22 @@ let new_Type_sort () = Type (new_univ ())
 (* This refreshes universes in types; works only for inferred types (i.e. for
    types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
    head normal form) *)
-let refresh_universes t =
+let refresh_universes_gen strict t =
   let modified = ref false in
   let rec refresh t = match kind_of_term t with
-    | Sort (Type _) -> modified := true; new_Type ()
+    | Sort (Type u) when strict or u <> Univ.type0m_univ ->
+	modified := true; new_Type ()
     | Prod (na,u,v) -> mkProd (na,u,refresh v)
     | _ -> t in
   let t' = refresh t in
   if !modified then t' else t
 
+let refresh_universes = refresh_universes_gen false
+let refresh_universes_strict = refresh_universes_gen true
+
 let new_sort_in_family = function 
-  | InProp -> mk_Prop
-  | InSet -> mk_Set
+  | InProp -> prop_sort
+  | InSet -> set_sort
   | InType -> Type (new_univ ())
 
 
@@ -214,7 +218,7 @@ let push_named_rec_types (lna,typarray,_) env =
     array_map2_i
       (fun i na t ->
 	 match na with
-	   | Name id -> (id, None, type_app (lift i) t)
+	   | Name id -> (id, None, lift i t)
 	   | Anonymous -> anomaly "Fix declarations must be named")
       lna typarray in
   Array.fold_left
@@ -271,6 +275,11 @@ let rec strip_head_cast c = match kind_of_term c with
   | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
 
+(* Get the last arg of an application *)
+let last_arg c = match kind_of_term c with
+  | App (f,cl) -> array_last cl
+  | _ -> anomaly "last_arg"
+
 (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
    subterms of [c]; it carries an extra data [l] (typically a name
    list) which is processed by [g na] (which typically cons [na] to
@@ -305,11 +314,8 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with
    (co-)fixpoint) *)
 
 let fold_rec_types g (lna,typarray,_) e =
-  let ctxt =
-    array_map2_i
-      (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in
-  Array.fold_left
-    (fun e assum -> g assum e) e ctxt
+  let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
+  Array.fold_left (fun e assum -> g assum e) e ctxt
 
 
 let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
@@ -514,6 +520,16 @@ let free_rels m =
   in 
   frec 1 Intset.empty m
 
+(* collects all metavar occurences, in left-to-right order, preserving
+ * repetitions and all. *)
+
+let collect_metas c = 
+  let rec collrec acc c =
+    match kind_of_term c with
+      | Meta mv -> list_add_set mv acc
+      | _       -> fold_constr collrec acc c
+  in
+  List.rev (collrec [] c)
 
 (* (dependent M N) is true iff M is eq_term with a subterm of N 
    M is appropriately lifted through abstractions of N *)
@@ -610,32 +626,34 @@ let subst_term = subst_term_gen eq_constr
 
 let replace_term = replace_term_gen eq_constr
 
-(* Substitute only a list of locations locs, the empty list is
-   interpreted as substitute all, if 0 is in the list then no
-   bindings is done. The list may contain only negative occurrences
-   that will not be substituted. *)
+(* Substitute only at a list of locations or excluding a list of
+   locations; in the occurrences list (b,l), b=true means no
+   occurrence except the ones in l and b=false, means all occurrences
+   except the ones in l *)
+
+type occurrences = bool * int list
+let all_occurrences = (false,[])
+let no_occurrences_in_set = (true,[])
 
 let error_invalid_occurrence l =
+  let l = list_uniquize (List.sort Pervasives.compare l) in
   errorlabstrm ""
     (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ 
      prlist_with_sep spc int l)
 
-let subst_term_occ_gen locs occ c t =
+let subst_term_occ_gen (nowhere_except_in,locs) occ c t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref occ in
-  let except = List.exists (fun n -> n<0) locs in
-  if except & (List.exists (fun n -> n>=0) locs) 
-  then error "mixing of positive and negative occurences"
-  else
-   let rec substrec (k,c as kc) t =
-    if (not except) & (!pos > maxocc) then t
+  assert (List.for_all (fun x -> x >= 0) locs);
+  let rec substrec (k,c as kc) t =
+    if nowhere_except_in & !pos > maxocc then t
     else
     if eq_constr c t then
       let r = 
-	if except then 
-	  if List.mem (- !pos) locs then t else (mkRel k)
-	else 
+	if nowhere_except_in then
 	  if List.mem !pos locs then (mkRel k) else t
+	else 
+	  if List.mem !pos locs then t else (mkRel k)
       in incr pos; r
     else
       map_constr_with_binders_left_to_right
@@ -645,40 +663,33 @@ let subst_term_occ_gen locs occ c t =
   let t' = substrec (1,c) t in
   (!pos, t')
 
-let subst_term_occ locs c t = 
-  if locs = [] then subst_term c t
-  else if List.mem 0 locs then 
-    t
+let subst_term_occ (nowhere_except_in,locs as plocs) c t = 
+  if locs = [] then if nowhere_except_in then t else subst_term c t
   else 
-    let (nbocc,t') = subst_term_occ_gen locs 1 c t in
-    let rest = List.filter (fun o -> o >= nbocc or o <= -nbocc) locs in
+    let (nbocc,t') = subst_term_occ_gen plocs 1 c t in
+    let rest = List.filter (fun o -> o >= nbocc) locs in
     if rest <> [] then error_invalid_occurrence rest;
     t'
 
-let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
+let subst_term_occ_decl (nowhere_except_in,locs as plocs) c (id,bodyopt,typ as d) =
   match bodyopt with
-    | None -> (id,None,subst_term_occ locs c typ)
+    | None -> (id,None,subst_term_occ plocs c typ)
     | Some body -> 
 	if locs = [] then
-	  (id,Some (subst_term c body),type_app (subst_term c) typ)
-	else if List.mem 0 locs then 
-	  d
+	  if nowhere_except_in then d
+	  else (id,Some (subst_term c body),subst_term c typ)
 	else 
-	  let (nbocc,body') = subst_term_occ_gen locs 1 c body in
-	  let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in
-	  let rest = List.filter (fun o -> o >= nbocc' or o <= -nbocc') locs in
+	  let (nbocc,body') = subst_term_occ_gen plocs 1 c body in
+	  let (nbocc',t') = subst_term_occ_gen plocs nbocc c typ in
+	  let rest = List.filter (fun o -> o >= nbocc') locs in
 	  if rest <> [] then error_invalid_occurrence rest;
 	  (id,Some body',t')
 
 
 (* First character of a constr *)
 
-let first_char id =
-  let id = string_of_id id in
-  assert (id <> "");
-  String.make 1 id.[0]
-
-let lowercase_first_char id = String.lowercase (first_char id)
+let lowercase_first_char id =
+  lowercase_first_char_utf8 (string_of_id id)
 
 let vars_of_env env =
   let s = 
@@ -707,8 +718,7 @@ let hdchar env c =
     | Cast (c,_,_)         -> hdrec k c
     | App (f,l)         -> hdrec k f
     | Const kn       ->
-	let c = lowercase_first_char (id_of_label (con_label kn)) in
-	if c = "?" then "y" else c
+	lowercase_first_char (id_of_label (con_label kn))
     | Ind ((kn,i) as x) ->
 	if i=0 then 
 	  lowercase_first_char (id_of_label (label kn))
@@ -743,20 +753,18 @@ let named_hd env a = function
   | Anonymous -> Name (id_of_string (hdchar env a)) 
   | x         -> x
 
-let named_hd_type env a = named_hd env (body_of_type a)
-
-let mkProd_name   env (n,a,b) = mkProd (named_hd_type env a n, a, b)
-let mkLambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+let mkProd_name   env (n,a,b) = mkProd (named_hd env a n, a, b)
+let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b)
 
 let lambda_name = mkLambda_name
 let prod_name = mkProd_name
 
-let prod_create   env (a,b) = mkProd (named_hd_type env a Anonymous, a, b)
-let lambda_create env (a,b) =  mkLambda (named_hd_type env a Anonymous, a, b)
+let prod_create   env (a,b) = mkProd (named_hd env a Anonymous, a, b)
+let lambda_create env (a,b) =  mkLambda (named_hd env a Anonymous, a, b)
 
 let name_assumption env (na,c,t) =
   match c with
-    | None      -> (named_hd_type env t na, None, t)
+    | None      -> (named_hd env t na, None, t)
     | Some body -> (named_hd env body na, c, t)
 
 let name_context env hyps =
@@ -834,6 +842,14 @@ let is_global id =
   with Not_found -> 
     false
 
+let is_constructor id =
+  try 
+    match locate (make_short_qualid id) with 
+      | ConstructRef _ as ref -> not (is_imported_ref ref)
+      | _ -> false
+  with Not_found -> 
+    false
+
 let is_section_variable id =
   try let _ = Global.lookup_named id in true
   with Not_found -> false
@@ -860,6 +876,11 @@ let isGlobalRef c =
   | Const _ | Ind _ | Construct _ | Var _ -> true
   | _ -> false
 
+let has_polymorphic_type c =
+  match (Global.lookup_constant c).Declarations.const_type with
+  | Declarations.PolymorphicArity _ -> true
+  | _ -> false
+
 (* nouvelle version de renommage des variables (DEC 98) *)
 (* This is the algorithm to display distinct bound variables 
 
@@ -898,11 +919,19 @@ let occur_id nenv id0 c =
   with Occur -> true
     | Not_found -> false (* Case when a global is not in the env *)
 
-let next_name_not_occuring is_goal_ccl name l env_names t =
+type avoid_flags = bool option
+
+let next_name_not_occuring avoid_flags name l env_names t =
   let rec next id =
     if List.mem id l or occur_id env_names id t or 
-      (* To be consistent with intro mechanism *)
-      (is_goal_ccl & is_global id & not (is_section_variable id))
+      (* Further restrictions ? *)
+      match avoid_flags with None -> false | Some not_only_cstr ->
+      (if not_only_cstr then
+	(* To be consistent with the intro mechanism *)
+	is_global id & not (is_section_variable id)
+      else
+	(* To avoid constructors in pattern-matchings *)
+	is_constructor id)
     then next (lift_ident id)
     else id
   in 
@@ -914,6 +943,22 @@ let next_name_not_occuring is_goal_ccl name l env_names t =
         (* invent a valid name *)
         next (id_of_string "H")
 
+let base_sort_cmp pb s0 s1 =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) -> c1 = Null or c2 = Pos  (* Prop <= Set *)
+    | (Prop c1, Type u)  -> pb = Reduction.CUMUL
+    | (Type u1, Type u2) -> true
+    | _ -> false
+
+(* eq_constr extended with universe erasure *)
+let rec constr_cmp cv_pb t1 t2 =
+  (match kind_of_term t1, kind_of_term t2 with
+      Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2
+    | _ -> false)
+  || compare_constr (constr_cmp cv_pb) t1 t2
+
+let eq_constr = constr_cmp Reduction.CONV
+
 (* On reduit une serie d'eta-redex de tete ou rien du tout  *)
 (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
 (* Remplace 2 versions précédentes buggées                  *)
@@ -939,6 +984,7 @@ let rec eta_reduce_head c =
            | _ -> c)
     | _ -> c
 
+
 (* alpha-eta conversion : ignore print names and casts *)
 let eta_eq_constr =
   let rec aux t1 t2 =
@@ -963,14 +1009,18 @@ let assums_of_rel_context sign =
         | None -> (na, t)::l)
     sign ~init:[]
 
-let lift_rel_context n sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,option_map (liftn n k) c,type_app (liftn n k) t)
-	::(liftrec (k-1) sign)
+let map_rel_context_with_binders f sign =
+  let rec aux k = function
+    | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign
     | [] -> []
   in
-  liftrec (rel_context_length sign) sign
+  aux (rel_context_length sign) sign
+
+let substl_rel_context l =
+  map_rel_context_with_binders (fun k -> substnl l (k-1))
+
+let lift_rel_context n =
+  map_rel_context_with_binders (liftn n)
 
 let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init
 
@@ -996,34 +1046,42 @@ let global_vars_set_of_decl env = function
       Idset.union (global_vars_set env t)
         (global_vars_set env c)
 
+let default_x = id_of_string "x"
+
+let rec next_name_away_in_cases_pattern id avoid =
+  let id = match id with Name id -> id | Anonymous -> default_x in
+  let rec next id =
+    if List.mem id avoid or is_constructor id then next (lift_ident id)
+    else id in
+  next id
+
 (* Remark: Anonymous var may be dependent in Evar's contexts *)
-let concrete_name is_goal_ccl l env_names n c =
+let concrete_name avoid_flags l env_names n c =
   if n = Anonymous & noccurn 1 c then
     (Anonymous,l)
   else
-    let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in
+    let fresh_id = next_name_not_occuring avoid_flags n l env_names c in
     let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
     (idopt, fresh_id::l)
 
-let concrete_let_name is_goal_ccl l env_names n c =
-  let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in
+let concrete_let_name avoid_flags l env_names n c =
+  let fresh_id = next_name_not_occuring avoid_flags n l env_names c in
   (Name fresh_id, fresh_id::l)
 
-let rec rename_bound_var env l c =
-  match kind_of_term c with
-  | Prod (Name s,c1,c2)  ->
-      if noccurn 1 c2 then
-        let env' = push_rel (Name s,None,c1) env in
-	mkProd (Name s, c1, rename_bound_var env' l c2)
-      else 
-        let s' = next_ident_away s (global_vars env c2@l) in
-        let env' = push_rel (Name s',None,c1) env in
-        mkProd (Name s', c1, rename_bound_var env' (s'::l) c2)
-  | Prod (Anonymous,c1,c2) ->
-        let env' = push_rel (Anonymous,None,c1) env in
-        mkProd (Anonymous, c1, rename_bound_var env' l c2)
-  | Cast (c,k,t) -> mkCast (rename_bound_var env l c, k,t)
-  | x -> c
+let rec rename_bound_var env avoid c =
+  let env_names = names_of_rel_context env in
+  let rec rename avoid c =
+    match kind_of_term c with
+    | Prod (na,c1,c2)  ->
+	let na',avoid' = concrete_name None avoid env_names na c2 in
+	mkProd (na', c1, rename avoid' c2)
+    | LetIn (na,c1,t,c2) ->
+	let na',avoid' = concrete_let_name None avoid env_names na c2 in
+	mkLetIn (na',c1,t, rename avoid' c2)
+    | Cast (c,k,t) -> mkCast (rename avoid c, k,t)
+    | _ -> c
+  in
+  rename avoid c
 
 (* Combinators on judgments *)
 
@@ -1031,3 +1089,13 @@ let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
 let on_judgment_value f j = { j with uj_val = f j.uj_val }
 let on_judgment_type f j = { j with uj_type = f j.uj_type }
 
+(* 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)
+    | (_, []) -> anomaly "context_chop"
+  in chop_aux [] (k,ctx)
+
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index e406b148..94aff66f 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termops.mli 9314 2006-10-29 20:11:08Z herbelin $ i*)
+(*i $Id: termops.mli 11166 2008-06-22 13:23:35Z herbelin $ i*)
 
 open Util
 open Pp
@@ -21,6 +21,7 @@ val new_sort_in_family : sorts_family -> sorts
 val new_Type : unit -> types
 val new_Type_sort : unit -> sorts
 val refresh_universes : types -> types
+val refresh_universes_strict : types -> types
 
 (* printers *)
 val print_sort : sorts -> std_ppcmds
@@ -30,6 +31,7 @@ val set_print_constr : (env -> constr -> std_ppcmds) -> unit
 val print_constr     : constr -> std_ppcmds
 val print_constr_env : env -> constr -> std_ppcmds
 val print_named_context : env -> std_ppcmds
+val pr_rel_decl : env -> rel_declaration -> std_ppcmds
 val print_rel_context : env -> std_ppcmds
 val print_env : env -> std_ppcmds
 
@@ -100,7 +102,8 @@ val occur_var_in_decl :
   identifier -> 'a * types option * types -> bool
 val occur_term : constr -> constr -> bool
 val free_rels : constr -> Intset.t
-
+val dependent : constr -> constr -> bool
+val collect_metas : constr -> int list
 (* Substitution of metavariables *)
 type metamap = (metavariable * constr) list 
 val subst_meta : metamap -> constr -> constr
@@ -108,37 +111,62 @@ val subst_meta : metamap -> constr -> constr
 (* [pop c] lifts by -1 the positive indexes in [c] *)
 val pop : constr -> constr
 
-(* bindings of an arbitrary large term. Uses equality modulo
+(*s Substitution of an arbitrary large term. Uses equality modulo
    reduction of let *)
-val dependent : constr -> constr -> bool
+
+(* [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
+   as equality *)
 val subst_term_gen :
   (constr -> constr -> bool) -> constr -> constr -> constr
+
+(* [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq]
+   as equality *)
 val replace_term_gen :
   (constr -> constr -> bool) ->
     constr -> constr -> constr -> constr
+
+(* [subst_term d c] replaces [Rel 1] by [d] in [c] *)
 val subst_term : constr -> constr -> constr
+
+(* [replace_term d e c] replaces [d] by [e] in [c] *)
 val replace_term : constr -> constr -> constr -> constr
-val subst_term_occ_gen :
-  int list -> int -> constr -> types -> int * types
-val subst_term_occ : int list -> constr -> types -> types
+
+(* In occurrences sets, false = everywhere except and true = nowhere except *)
+type occurrences = bool * int list
+val all_occurrences : occurrences
+val no_occurrences_in_set : occurrences
+
+(* [subst_term_occ_gen occl n c d] replaces occurrences of [c] at
+   positions [occl], counting from [n], by [Rel 1] in [d] *)
+val subst_term_occ_gen : 
+  occurrences -> int -> constr -> types -> int * types
+
+(* [subst_term_occ occl c d] replaces occurrences of [c] at
+   positions [occl] by [Rel 1] in [d] (see also Note OCC) *)
+val subst_term_occ : occurrences -> constr -> constr -> constr
+
+(* [subst_term_occ_decl occl c decl] replaces occurrences of [c] at
+   positions [occl] by [Rel 1] in [decl] *)
 val subst_term_occ_decl :
-  int list -> constr -> named_declaration -> named_declaration
+  occurrences -> constr -> named_declaration -> named_declaration
 
 val error_invalid_occurrence : int list -> 'a
 
 (* Alternative term equalities *)
+val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool
+val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool
+val eq_constr : constr -> constr -> bool
+
 val eta_reduce_head : constr -> constr
 val eta_eq_constr : constr -> constr -> bool
 
 (* finding "intuitive" names to hypotheses *)
-val first_char : identifier -> string
 val lowercase_first_char : identifier -> string
 val sort_hdchar : sorts -> string
 val hdchar : env -> types -> string
 val id_of_name_using_hdchar :
   env -> types -> name -> identifier
 val named_hd : env -> types -> name -> name
-val named_hd_type : env -> types -> name -> name
 
 val mkProd_name : env -> name * types * types -> types
 val mkLambda_name : env -> name * types * constr -> constr
@@ -157,6 +185,9 @@ val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr
 val it_mkProd_or_LetIn_name   : env -> types -> rel_context -> types
 val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
 
+(* Get the last arg of a constr intended to be nn application *)
+val last_arg : constr -> constr
+
 (* name contexts *)
 type names_context = name list
 val add_name : name -> names_context -> names_context
@@ -168,6 +199,8 @@ val ids_of_named_context : named_context -> identifier list
 val ids_of_context : env -> identifier list
 val names_of_rel_context : env -> names_context
 
+val context_chop : int -> rel_context -> (rel_context*rel_context)
+
 (* Set of local names *)
 val vars_of_env: env -> Idset.t
 val add_vname : Idset.t -> name -> Idset.t
@@ -177,21 +210,31 @@ type used_idents = identifier list
 val occur_rel : int -> name list -> identifier -> bool
 val occur_id : name list -> identifier -> constr -> bool
 
+type avoid_flags = bool option
+ (* Some true = avoid all globals (as in intro); 
+    Some false = avoid only global constructors; None = don't avoid globals *)
+
+val next_name_away_in_cases_pattern : 
+  name -> identifier list -> identifier
 val next_global_ident_away : 
   (*allow section vars:*) bool -> identifier -> identifier list -> identifier
 val next_name_not_occuring :
-  bool -> name -> identifier list -> name list -> constr -> identifier
+  avoid_flags -> name -> identifier list -> name list -> constr -> identifier
 val concrete_name :
-  bool -> identifier list -> name list -> name -> constr -> 
+  avoid_flags -> identifier list -> name list -> name -> constr -> 
     name * identifier list
 val concrete_let_name :
-  bool -> identifier list -> name list -> name -> constr -> name * identifier list
+  avoid_flags -> identifier list -> name list -> name -> constr -> 
+    name * identifier list
 val rename_bound_var : env -> identifier list -> types -> types
 
 (* other signature iterators *)
 val process_rel_context : (rel_declaration -> env -> env) -> env -> env
 val assums_of_rel_context : rel_context -> (name * constr) list
 val lift_rel_context : int -> rel_context -> rel_context
+val substl_rel_context : constr list -> rel_context -> rel_context
+val map_rel_context_with_binders : 
+  (int -> constr -> constr) -> rel_context -> rel_context
 val fold_named_context_both_sides :
   ('a -> named_declaration -> named_declaration list -> 'a) ->
     named_context -> init:'a -> 'a
@@ -206,6 +249,8 @@ val is_section_variable : identifier -> bool
 
 val isGlobalRef : constr -> bool
 
+val has_polymorphic_type : constant -> bool
+
 (* Combinators on judgments *)
 
 val on_judgment       : (types -> types) -> unsafe_judgment -> unsafe_judgment
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
new file mode 100644
index 00000000..a2392033
--- /dev/null
+++ b/pretyping/typeclasses.ml
@@ -0,0 +1,457 @@
+(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typeclasses.ml 11143 2008-06-18 15:52:42Z msozeau $ i*)
+
+(*i*)
+open Names
+open Libnames
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Util
+open Typeclasses_errors
+(*i*)
+
+let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
+(* let mismatched_defs env n m = mismatched_ctx_inst env Definitions n m *)
+let mismatched_props env n m = mismatched_ctx_inst env Properties n m
+
+type rels = constr list
+
+(* This module defines type-classes *)
+type typeclass = {
+  (* The class implementation *)
+  cl_impl : global_reference; 
+
+  (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *)
+  cl_context : ((global_reference * bool) option * named_declaration) list; 
+
+  cl_params: int;
+
+  (* Context of definitions and properties on defs, will not be shared *)
+  cl_props : named_context;
+  
+  (* The method implementaions as projections. *)
+  cl_projs : (identifier * constant) list;
+}
+
+type typeclasses = (global_reference, typeclass) Gmap.t
+
+type globality = int option
+
+type instance = {
+  is_class: global_reference;
+  is_pri: int option;
+  is_global: globality;
+  (* Sections where the instance should be redeclared, 
+     Some n for n sections, None for discard at end of section. *)
+  is_impl: constant; 
+}
+
+type instances = (global_reference, instance Cmap.t) Gmap.t
+
+let instance_impl is = is.is_impl
+
+let new_instance cl pri glob impl = 
+  let global =
+    if Lib.sections_are_opened () then 
+      if glob then Some (Lib.sections_depth ())
+      else None
+    else Some 0
+  in
+    { is_class = cl.cl_impl;
+      is_pri = pri ;
+      is_global = global ;
+      is_impl = impl }
+	
+let classes : typeclasses ref = ref Gmap.empty
+
+let methods : (constant, global_reference) Gmap.t ref = ref Gmap.empty
+  
+let instances : instances ref = ref Gmap.empty
+  
+let freeze () = !classes, !methods, !instances
+
+let unfreeze (cl,m,is) = 
+  classes:=cl;
+  methods:=m;
+  instances:=is
+    
+let init () =
+  classes:= Gmap.empty; 
+  methods:= Gmap.empty;
+  instances:= Gmap.empty
+    
+let _ = 
+  Summary.declare_summary "classes_and_instances"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = true }
+
+let gmap_merge old ne =
+  Gmap.fold (fun k v acc -> Gmap.add k v acc) old ne
+
+let cmap_union = Cmap.fold Cmap.add
+
+let gmap_cmap_merge old ne =
+  let ne' = 
+    Gmap.fold (fun cl insts acc -> 
+      let oldinsts = try Gmap.find cl old with Not_found -> Cmap.empty in
+	Gmap.add cl (cmap_union oldinsts insts) acc)
+      Gmap.empty ne
+  in
+    Gmap.fold (fun cl insts acc -> 
+      if Gmap.mem cl ne' then acc
+      else Gmap.add cl insts acc)
+      ne' old
+      
+let add_instance_hint_ref = ref (fun id pri -> assert false)
+let register_add_instance_hint =
+  (:=) add_instance_hint_ref
+let add_instance_hint id = !add_instance_hint_ref id
+
+let cache (_, (cl, m, inst)) =
+  classes := cl;
+  methods := m;
+  instances := inst
+    
+let load (_, (cl, m, inst)) =
+  classes := gmap_merge !classes cl;
+  methods := gmap_merge !methods m;
+  instances := gmap_cmap_merge !instances inst
+
+open Libobject
+
+let subst (_,subst,(cl,m,inst)) = 
+  let do_subst_con c = fst (Mod_subst.subst_con 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_named ctx = 
+    list_smartmap (fun (na, b, t) ->
+      (na, Option.smartmap do_subst b, do_subst t))
+      ctx
+  in
+  let do_subst_ctx ctx = 
+    list_smartmap (fun (cl, (na, b, t)) ->
+      (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b) cl,
+      (na, Option.smartmap do_subst b, do_subst t)))
+      ctx
+  in
+  let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, do_subst_con y)) projs in
+  let subst_class k cl classes = 
+    let k = do_subst_gr k in
+    let cl' = { cl with cl_impl = k;
+		cl_context = do_subst_ctx cl.cl_context;
+		cl_props = do_subst_named cl.cl_props;
+		cl_projs = do_subst_projs cl.cl_projs; }
+    in 
+    let cl' = if cl' = cl then cl else cl' in
+      Gmap.add k cl' classes
+  in
+  let classes = Gmap.fold subst_class cl Gmap.empty in
+  let subst_inst k insts instances =
+    let k = do_subst_gr k in
+    let insts' = 
+      Cmap.fold (fun cst is acc -> 
+	let cst = do_subst_con cst in
+	let is' = { is with is_class = k; is_impl = cst } in
+	  Cmap.add cst (if is' = is then is else is') acc) insts Cmap.empty
+    in Gmap.add k insts' instances
+  in
+  let instances = Gmap.fold subst_inst inst Gmap.empty in
+    (classes, m, instances)
+
+let discharge (_,(cl,m,inst)) =
+  let discharge_named (cl, r) =
+    Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b) cl, r
+  in
+  let abs_context cl =
+    match cl.cl_impl with
+    | VarRef _ | ConstructRef _ -> assert false
+    | ConstRef cst -> Lib.section_segment_of_constant cst
+    | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind
+  in
+  let subst_class k cl acc = 
+    let cl_impl' = Lib.discharge_global cl.cl_impl in
+    let cl' =
+      if cl_impl' == cl.cl_impl then cl
+      else
+	{ cl with cl_impl = cl_impl';
+	  cl_context = 
+	    List.map (fun x -> None, x) (abs_context cl) @	
+	      (list_smartmap discharge_named cl.cl_context);
+	  cl_projs = list_smartmap (fun (x, y) -> x, Lib.discharge_con y) cl.cl_projs }
+    in Gmap.add cl_impl' cl' acc
+  in
+  let classes = Gmap.fold subst_class cl Gmap.empty in
+  let subst_inst k insts acc =
+    let k' = Lib.discharge_global k in
+    let insts' =
+      Cmap.fold (fun k is acc ->
+	let impl = Lib.discharge_con is.is_impl in
+	let is = { is with is_class = k'; is_impl = impl } in
+	  Cmap.add impl is acc)
+	insts Cmap.empty
+    in Gmap.add k' insts' acc
+  in
+  let instances = Gmap.fold subst_inst inst Gmap.empty in
+    Some (classes, m, instances)
+      
+let rebuild (_,(cl,m,inst)) =
+  let inst = 
+    Gmap.map (fun insts -> 
+      Cmap.fold (fun k is insts -> 
+	match is.is_global with
+	  | None -> insts
+	  | Some 0 -> Cmap.add k is insts
+	  | Some n -> 
+	      add_instance_hint is.is_impl is.is_pri;
+	      let is' = { is with is_global = Some (pred n) }
+	      in Cmap.add k is' insts) insts Cmap.empty)
+      inst
+  in (cl, m, inst)
+
+let (input,output) = 
+  declare_object
+    { (default_object "type classes state") with
+      cache_function = cache;
+      load_function = (fun _ -> load);
+      open_function = (fun _ -> load);
+      classify_function = (fun (_,x) -> Substitute x);
+      discharge_function = discharge;
+      rebuild_function = rebuild;
+      subst_function = subst;
+      export_function = (fun x -> Some x) }
+
+let update () = 
+  Lib.add_anonymous_leaf (input (!classes, !methods, !instances))
+
+let add_class c = 
+  classes := Gmap.add c.cl_impl c !classes;
+  methods := List.fold_left (fun acc x -> Gmap.add (snd x) c.cl_impl acc) !methods c.cl_projs;
+  update ()
+    
+let class_info c = 
+  try Gmap.find c !classes
+  with _ -> not_a_class (Global.env()) (constr_of_global c)
+
+let instance_constructor cl args = 
+  let pars = fst (list_chop (List.length cl.cl_context) args) in
+    match cl.cl_impl with
+      | IndRef ind -> applistc (mkConstruct (ind, 1)) args,
+	  applistc (mkInd ind) pars
+      | ConstRef cst -> list_last args, applistc (mkConst cst) pars
+      | _ -> assert false
+	  
+let typeclasses () = Gmap.fold (fun _ l c -> l :: c) !classes []
+
+let cmapl_add x y m =
+  try
+    let l = Gmap.find x m in
+    Gmap.add x (Cmap.add y.is_impl y l) m
+  with Not_found ->
+    Gmap.add x (Cmap.add y.is_impl y Cmap.empty) m
+
+let cmap_elements c = Cmap.fold (fun k v acc -> v :: acc) c []
+
+let instances_of c = 
+  try cmap_elements (Gmap.find c.cl_impl !instances) with Not_found -> []
+
+let add_instance i =
+  let cl = class_info i.is_class in
+  instances := cmapl_add cl.cl_impl i !instances;
+  add_instance_hint i.is_impl i.is_pri;
+  update ()
+
+let instances r = 
+  let cl = class_info r in instances_of cl
+
+let solve_instanciation_problem = ref (fun _ _ _ _ -> assert false)
+let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false)
+
+let resolve_typeclass env ev evi (evd, defined as acc) =
+  try
+    assert(evi.evar_body = Evar_empty);
+    !solve_instanciation_problem env evd ev evi
+  with Exit -> acc
+
+let resolve_one_typeclass env types =
+  try
+    let evi = Evd.make_evar (Environ.named_context_val env) types in
+    let ev = 1 in
+    let evm = Evd.add Evd.empty ev evi in
+    let evd = Evd.create_evar_defs evm in
+    let evd', b = !solve_instanciation_problem env evd ev evi in
+      if b then 
+	let evm' = Evd.evars_of evd' in
+	  match Evd.evar_body (Evd.find evm' ev) with
+	      Evar_empty -> raise Not_found
+	    | Evar_defined c -> c
+      else raise Not_found
+  with Exit -> raise Not_found
+
+let resolve_one_typeclass_evd env evd types =
+  try
+    let ev = Evarutil.e_new_evar evd env types in
+    let (ev,_) = destEvar ev in
+    let evd', b =
+	!solve_instanciation_problem env !evd ev (Evd.find (Evd.evars_of !evd) ev)
+    in
+      evd := evd';
+      if b then 
+	let evm' = Evd.evars_of evd' in
+	  match Evd.evar_body (Evd.find evm' ev) with
+	      Evar_empty -> raise Not_found
+	    | Evar_defined c -> Evarutil.nf_evar evm' c
+      else raise Not_found
+  with Exit -> raise Not_found
+
+let method_typeclass ref = 
+  match ref with 
+    | ConstRef c -> 
+	class_info (Gmap.find c !methods)
+    | _ -> raise Not_found
+      
+let is_class gr = 
+  Gmap.fold (fun k v acc -> acc || v.cl_impl = gr) !classes false
+  
+let is_method c =
+  Gmap.mem c !methods
+
+let is_instance = function
+  | ConstRef c ->
+      (match Decls.constant_kind c with
+      | IsDefinition Instance -> true
+      | _ -> false)
+  | VarRef v ->
+      (match Decls.variable_kind v with
+      | IsDefinition Instance -> true
+      | _ -> false)
+  | _ -> false
+
+let is_implicit_arg k = 
+  match k with
+      ImplicitArg (ref, (n, id)) -> true
+    | InternalHole -> true
+    | _ -> false
+
+let destClassApp c = 
+  match kind_of_term c with
+    | App (ki, args) when isInd ki -> 
+	Some (destInd ki, args)
+    | _ when isInd c -> Some (destInd c, [||])
+    | _ -> None
+
+let is_independent evm ev = 
+  Evd.fold (fun ev' evi indep -> indep && 
+    (ev = ev' || 
+	evi.evar_body <> Evar_empty ||
+	not (Termops.occur_evar ev evi.evar_concl)))
+    evm true
+    
+
+(*   try !solve_instanciations_problem env (Evarutil.nf_evar_defs evd) *)
+(*   with _ -> *)
+(*   let evm = Evd.evars_of evd in *)
+(*   let tc_evars =  *)
+(*     let f ev evi acc = *)
+(*       let (l, k) = Evd.evar_source ev evd in *)
+(* 	if not check || is_implicit_arg k then *)
+(* 	  match destClassApp evi.evar_concl with *)
+(* 	    | Some (i, args) when is_class i ->  *)
+(* 		Evd.add acc ev evi *)
+(* 	    | _ -> acc *)
+(* 	else acc *)
+(*     in Evd.fold f evm Evd.empty *)
+(*   in *)
+(*   let rec sat evars = *)
+(*     let evm = Evd.evars_of evars in *)
+(*     let (evars', progress) =  *)
+(*       Evd.fold  *)
+(* 	(fun ev evi acc ->  *)
+(* 	  if (Evd.mem tc_evars ev || not (Evd.mem evm ev))  *)
+(* 	    && evi.evar_body = Evar_empty then *)
+(* 	    resolve_typeclass env ev evi acc  *)
+(* 	  else acc) *)
+(* 	evm (evars, false)  *)
+(*     in *)
+(*       if not progress then evars' *)
+(*       else *)
+(* 	sat (Evarutil.nf_evar_defs evars') *)
+(*   in sat (Evarutil.nf_evar_defs evd) *)
+  
+let class_of_constr c = 
+  let extract_cl c =
+    try Some (class_info (global_of_constr c)) with _ -> None
+  in
+    match kind_of_term c with
+	App (c, _) -> extract_cl c
+      | _ -> extract_cl c
+
+let dest_class_app c =
+  let cl c = class_info (global_of_constr c) in
+    match kind_of_term c with
+	App (c, args) -> cl c, args
+      | _ -> cl c, [||]
+
+(* To embed a boolean for resolvability status.
+   This is essentially a hack to mark which evars correspond to 
+   goals and do not need to be resolved when we have nested [resolve_all_evars] 
+   calls (e.g. when doing apply in an External hint in typeclass_instances).
+   Would be solved by having real evars-as-goals. *)
+
+let ((bool_in : bool -> Dyn.t),
+    (bool_out : Dyn.t -> bool)) = Dyn.create "bool"
+  
+let bool_false = bool_in false
+
+let is_resolvable evi =
+  match evi.evar_extra with
+      Some t -> if Dyn.tag t = "bool" then bool_out t else true
+    | None -> true
+	
+let mark_unresolvable evi = 
+  { evi with evar_extra = Some bool_false }
+    
+let mark_unresolvables sigma =
+  Evd.fold (fun ev evi evs ->
+    Evd.add evs ev (mark_unresolvable evi))
+    sigma Evd.empty
+    
+let has_typeclasses evd =
+  Evd.fold (fun ev evi has -> has || 
+    (evi.evar_body = Evar_empty && class_of_constr evi.evar_concl <> None 
+	&& is_resolvable evi))
+    evd false
+
+let resolve_typeclasses ?(onlyargs=false) ?(split=true) ?(fail=true) env evd =
+  if not (has_typeclasses (Evd.evars_of evd)) then evd
+  else
+    !solve_instanciations_problem env (Evarutil.nf_evar_defs evd) onlyargs split fail
+
+type substitution = (identifier * constr) list
+
+let substitution_of_named_context isevars env id n subst l = 
+  List.fold_right
+    (fun (na, _, t) subst -> 
+      let t' = replace_vars subst t in
+      let b = Evarutil.e_new_evar isevars env ~src:(dummy_loc, ImplicitArg (VarRef id, (n, Some na))) t' in
+	(na, b) :: subst)
+    l subst
+
+let nf_substitution sigma subst = 
+  List.map (function (na, c) -> na, Reductionops.nf_evar sigma c) subst
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
new file mode 100644
index 00000000..a3118053
--- /dev/null
+++ b/pretyping/typeclasses.mli
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typeclasses.mli 11161 2008-06-21 14:32:47Z msozeau $ i*)
+
+(*i*)
+open Names
+open Libnames
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Topconstr
+open Util
+(*i*)
+
+(* This module defines type-classes *)
+type typeclass = {
+  (* The class implementation: a record parameterized by the context with defs in it or a definition if 
+     the class is a singleton. This acts as the classe's global identifier. *)
+  cl_impl : global_reference; 
+
+  (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. 
+     The boolean indicates if the typeclass argument is a direct superclass. *)
+  cl_context : ((global_reference * bool) option * named_declaration) list; 
+
+  cl_params : int; (* This is the length of the suffix of the context which should be considered explicit parameters. *)
+
+  (* Context of definitions and properties on defs, will not be shared *)
+  cl_props : named_context;
+
+  (* The methods implementations of the typeclass as projections. *)
+  cl_projs : (identifier * constant) list;
+}
+
+type instance
+
+val instance_impl : instance -> constant
+
+val new_instance : typeclass -> int option -> bool -> constant -> instance
+  
+val instances : global_reference -> instance list
+val typeclasses : unit -> typeclass list
+val add_class : typeclass -> unit
+val add_instance : instance -> unit
+
+val register_add_instance_hint : (constant -> int option -> unit) -> unit
+val add_instance_hint : constant -> int option -> unit
+
+val class_info : global_reference -> typeclass (* raises a UserError if not a class *)
+val is_class : global_reference -> bool
+val class_of_constr : constr -> typeclass option
+val dest_class_app : constr -> typeclass * constr array (* raises a UserError if not a class *)
+
+val is_instance : global_reference -> bool
+val is_method : constant -> bool
+
+(* Returns the term and type for the given instance of the parameters and fields
+   of the type class. *)
+val instance_constructor : typeclass -> constr list -> constr * types
+
+val resolve_one_typeclass : env -> types -> types (* Raises Not_found *)
+val resolve_one_typeclass_evd : env -> evar_defs ref -> types -> types (* Raises Not_found *)
+val resolve_typeclass : env -> evar -> evar_info -> evar_defs * bool -> evar_defs * bool
+
+(* Use evar_extra for marking resolvable evars. *)
+val bool_in : bool -> Dyn.t
+val bool_out : Dyn.t -> bool
+
+val is_resolvable : evar_info -> bool
+val mark_unresolvable : evar_info -> evar_info
+val mark_unresolvables : evar_map -> evar_map
+
+val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> env -> evar_defs -> evar_defs
+
+val solve_instanciation_problem : (env -> evar_defs -> existential_key -> evar_info -> evar_defs * bool) ref
+val solve_instanciations_problem : (env -> evar_defs -> bool -> bool -> bool -> evar_defs) ref
+
+type substitution = (identifier * constr) list
+
+val substitution_of_named_context : 
+  evar_defs ref -> env -> identifier -> int ->
+  substitution -> named_context -> substitution
+
+val nf_substitution : evar_map -> substitution -> substitution
+
+val is_implicit_arg : hole_kind -> bool
+
+(* debug *)
+
+(* val subst :  *)
+(*     'a * Mod_subst.substitution * *)
+(*     ((Libnames.global_reference, typeclass) Gmap.t * 'b * *)
+(*      ('c, instance list) Gmap.t) -> *)
+(*     (Libnames.global_reference, typeclass) Gmap.t * 'b * *)
+(*     ('c, instance list) Gmap.t *)
+
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
new file mode 100644
index 00000000..9faac94d
--- /dev/null
+++ b/pretyping/typeclasses_errors.ml
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typeclasses_errors.ml 11150 2008-06-19 11:38:27Z msozeau $ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Topconstr
+open Util
+open Libnames
+(*i*)
+
+type contexts = Parameters | Properties
+
+type typeclass_error = 
+    | NotAClass of constr
+    | UnboundMethod of global_reference * identifier located (* Class name, method *)
+    | NoInstance of identifier located * constr list
+    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
+    | MismatchedContextInstance of contexts * constr_expr list * named_context (* found, expected *)
+
+exception TypeClassError of env * typeclass_error
+
+let typeclass_error env err = raise (TypeClassError (env, err))
+
+let not_a_class env c = typeclass_error env (NotAClass c)
+
+let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id))
+
+let no_instance env id args = typeclass_error env (NoInstance (id, args))
+
+let unsatisfiable_constraints env evd ev = 
+  let evd = Evd.undefined_evars evd in
+    match ev with
+    | None ->
+	raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
+    | Some ev ->
+	let evi = Evd.find (Evd.evars_of evd) ev in
+	let loc, kind = Evd.evar_source ev evd in
+	  raise (Stdpp.Exc_located (loc, TypeClassError
+	    (env, UnsatisfiableConstraints (evd, Some (evi, kind)))))
+	    
+let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m))
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
new file mode 100644
index 00000000..6491372f
--- /dev/null
+++ b/pretyping/typeclasses_errors.mli
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typeclasses_errors.mli 11105 2008-06-11 13:47:21Z msozeau $ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Topconstr
+open Util
+open Libnames
+(*i*)
+
+type contexts = Parameters | Properties
+
+type typeclass_error = 
+    | NotAClass of constr
+    | UnboundMethod of global_reference * identifier located (* Class name, method *)
+    | NoInstance of identifier located * constr list
+    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
+    | MismatchedContextInstance of contexts * constr_expr list * named_context (* found, expected *)
+
+exception TypeClassError of env * typeclass_error
+
+val not_a_class : env -> constr -> 'a
+
+val unbound_method : env -> global_reference -> identifier located -> 'a
+
+val no_instance : env -> identifier located -> constr list -> 'a
+
+val unsatisfiable_constraints : env -> evar_defs -> evar option -> 'a
+
+val mismatched_ctx_inst : env -> contexts -> constr_expr list -> named_context -> 'a
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 6fa05fa5..43e19ca7 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typing.ml 9511 2007-01-22 08:27:31Z herbelin $ *)
+(* $Id: typing.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
 
 open Util
 open Names
@@ -20,14 +20,11 @@ open Inductiveops
 open Typeops
 open Evd
 
-let meta_type env mv =
+let meta_type evd mv =
   let ty =
-    try Evd.meta_ftype env mv
-    with Not_found -> error ("unknown meta ?"^string_of_int mv) in
-  meta_instance env ty
-
-let vect_lift = Array.mapi lift
-let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
+    try Evd.meta_ftype evd mv
+    with Not_found -> anomaly ("unknown meta ?"^Nameops.string_of_meta mv) in
+  meta_instance evd ty
 
 let constant_type_knowing_parameters env cst jl =
   let paramstyp = Array.map (fun j -> j.uj_type) jl in
@@ -169,8 +166,9 @@ let mcheck env evd c t =
  
 let mtype_of env evd c =
   let j = execute env evd (nf_evar (evars_of evd) c) in
-  (* No normalization: it breaks Pattern! *)
-  (*nf_betaiota*) (body_of_type j.uj_type)
+  (* We are outside the kernel: we take fresh universes *)
+  (* to avoid tactics and co to refresh universes themselves *)
+  Termops.refresh_universes j.uj_type
 
 let msort_of env evd c =
   let j = execute env evd (nf_evar (evars_of evd) c) in
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 5fb8054f..fc812594 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unification.ml 9517 2007-01-22 17:37:58Z herbelin $ *)
+(* $Id: unification.ml 11157 2008-06-21 10:45:51Z herbelin $ *)
 
 open Pp
 open Util
@@ -23,6 +23,8 @@ open Rawterm
 open Pattern
 open Evarutil
 open Pretype_errors
+open Retyping
+open Coercion.Default
 
 (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
    gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
@@ -31,31 +33,69 @@ let abstract_scheme env c l lname_typ =
   List.fold_left2 
     (fun t (locc,a) (na,_,ta) ->
        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...
        if occur_meta ta then error "cannot find a type for the generalisation"
-       else if occur_meta a then lambda_name env (na,ta,t)
+       else *) if occur_meta a then lambda_name env (na,ta,t)
        else lambda_name env (na,ta,subst_term_occ locc a t))
     c
     (List.rev l)
     lname_typ
 
-let abstract_list_all env sigma typ c l =
-  let ctxt,_ = decomp_n_prod env sigma (List.length l) typ in
-  let p = abstract_scheme env c (List.map (function a -> [],a) l) ctxt in 
+let abstract_list_all env evd typ c l =
+  let ctxt,_ = decomp_n_prod env (evars_of evd) (List.length l) typ in
+  let l_with_all_occs = List.map (function a -> (all_occurrences,a)) l in
+  let p = abstract_scheme env c l_with_all_occs ctxt in 
   try 
-    if is_conv_leq env sigma (Typing.type_of env sigma p) typ then p
+    if is_conv_leq env (evars_of evd) (Typing.mtype_of env evd p) typ then p
     else error "abstract_list_all"
-  with UserError _ ->
-    raise (PretypeError (env,CannotGeneralize typ))
+  with UserError _ | Type_errors.TypeError _ ->
+    error_cannot_find_well_typed_abstraction env (evars_of evd) p l
 
 (**)
 
+(* A refinement of [conv_pb]: the integers tells how many arguments
+   were applied in the context of the conversion problem; if the number
+   is non zero, steps of eta-expansion will be allowed
+*)
+
+type conv_pb_up_to_eta = Cumul | ConvUnderApp of int * int
+
+let topconv = ConvUnderApp (0,0)
+let of_conv_pb = function CONV -> topconv | CUMUL -> Cumul
+let conv_pb_of = function ConvUnderApp _ -> CONV | Cumul -> CUMUL
+let prod_pb = function ConvUnderApp _ -> topconv | pb -> pb
+
+let opp_status = function
+  | IsSuperType -> IsSubType
+  | IsSubType -> IsSuperType
+  | ConvUpToEta _ | UserGiven as x -> x
+
+let add_type_status (x,y) = ((x,TypeNotProcessed),(y,TypeNotProcessed))
+
+let extract_instance_status = function
+  | Cumul -> add_type_status (IsSubType, IsSuperType)
+  | ConvUnderApp (n1,n2) -> add_type_status (ConvUpToEta n1, ConvUpToEta n2)
+
+let rec assoc_pair x = function
+    [] -> raise Not_found
+  | (a,b,_)::l -> if compare a x = 0 then b else assoc_pair x l
+
+let rec subst_meta_instances bl c =
+  match kind_of_term c with
+    | Meta i -> (try assoc_pair i bl with Not_found -> c)
+    | _ -> map_constr (subst_meta_instances bl) c
+
 let solve_pattern_eqn_array env f l c (metasubst,evarsubst) =
   match kind_of_term f with
     | Meta k -> 
-	(k,solve_pattern_eqn env (Array.to_list l) c)::metasubst,evarsubst
+	let c = solve_pattern_eqn env (Array.to_list l) c in
+	let n = Array.length l - List.length (fst (decompose_lam c)) in
+	let pb = (ConvUpToEta n,TypeNotProcessed) in
+	(k,c,pb)::metasubst,evarsubst
     | Evar ev ->
       (* Currently unused: incompatible with eauto/eassumption backtracking *)
-	metasubst,(f,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
+	metasubst,(ev,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
     | _ -> assert false
 
 (*******************************)
@@ -78,79 +118,207 @@ let unify_r2l x = x
 let sort_eqns = unify_r2l
 *)
 
-let unify_0 env sigma cv_pb mod_delta m n =
-  let trivial_unify pb substn m n =
-    if (not(occur_meta m)) && 
-      (if mod_delta then is_fconv pb env sigma m n else eq_constr m n) 
-    then substn
-    else error_cannot_unify env sigma (m,n) in
-  let rec unirec_rec curenv pb ((metasubst,evarsubst) as substn) curm curn =
+type unify_flags = { 
+  modulo_conv_on_closed_terms : Names.transparent_state option;
+  use_metas_eagerly : bool;
+  modulo_delta : Names.transparent_state;
+}
+
+let default_unify_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly = true;
+  modulo_delta = full_transparent_state;
+}
+
+let default_no_delta_unify_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly = true;
+  modulo_delta = empty_transparent_state;
+}
+
+let expand_constant env flags c = 
+  match kind_of_term c with
+  | Const cst when is_transparent (ConstKey cst) &&
+                   Cpred.mem cst (snd flags.modulo_delta) ->
+      constant_opt_value env cst
+  | Var id when is_transparent (VarKey id) &&
+                Idpred.mem id (fst flags.modulo_delta) ->
+      named_body id env
+  | _ -> None
+
+let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n =
+  let nb = nb_rel env in
+  let trivial_unify pb (metasubst,_) m n =
+    let subst = if flags.use_metas_eagerly then metasubst else fst subst in
+    match subst_defined_metas subst m with
+    | Some m ->
+	(match flags.modulo_conv_on_closed_terms with
+	    Some flags ->
+	      is_trans_fconv (conv_pb_of pb) flags env sigma m n
+	  | None -> constr_cmp (conv_pb_of cv_pb) m n)
+    | _ -> constr_cmp (conv_pb_of cv_pb) m n in
+  let rec unirec_rec curenv pb b ((metasubst,evarsubst) as substn) curm curn =
     let cM = Evarutil.whd_castappevar sigma curm
     and cN = Evarutil.whd_castappevar sigma curn in 
       match (kind_of_term cM,kind_of_term cN) with
 	| Meta k1, Meta k2 ->
+	    let stM,stN = extract_instance_status pb in
 	    if k1 < k2 
-	    then (k1,cN)::metasubst,evarsubst
-	    else if k1 = k2 then substn else (k2,cM)::metasubst,evarsubst
+	    then (k1,cN,stN)::metasubst,evarsubst
+	    else if k1 = k2 then substn
+	    else (k2,cM,stM)::metasubst,evarsubst
 	| Meta k, _    -> 
 	    (* Here we check that [cN] does not contain any local variables *)
-	    if (closedn (nb_rel env) cN)
-	    then (k,cN)::metasubst,evarsubst
-	    else error_cannot_unify_local curenv sigma (curenv,m,n,cN)
+	    if (closedn nb cN)
+	    then (k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
+	    else error_cannot_unify_local curenv sigma (m,n,cN)
 	| _, Meta k    -> 
 	    (* Here we check that [cM] does not contain any local variables *)
-	    if (closedn (nb_rel env) cM) 
-	    then (k,cM)::metasubst,evarsubst
-	    else error_cannot_unify_local curenv sigma (curenv,m,n,cM)
-	| Evar _, _ -> metasubst,((cM,cN)::evarsubst)
-	| _, Evar _ -> metasubst,((cN,cM)::evarsubst)
+	    if (closedn nb cM)
+	    then (k,cM,fst (extract_instance_status pb))::metasubst,evarsubst
+	    else error_cannot_unify_local curenv sigma (m,n,cM)
+	| Evar ev, _ -> metasubst,((ev,cN)::evarsubst)
+	| _, Evar ev -> metasubst,((ev,cM)::evarsubst)
 	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
-	    unirec_rec (push_rel_assum (na,t1) curenv) CONV 
-	      (unirec_rec curenv CONV substn t1 t2) c1 c2
+	    unirec_rec (push_rel_assum (na,t1) curenv) topconv true
+	      (unirec_rec curenv topconv true substn t1 t2) c1 c2
 	| Prod (na,t1,c1), Prod (_,t2,c2) ->
-	    unirec_rec (push_rel_assum (na,t1) curenv) pb 
-	      (unirec_rec curenv CONV substn t1 t2) c1 c2
-	| LetIn (_,b,_,c), _ -> unirec_rec curenv  pb substn (subst1 b c) cN
-	| _, LetIn (_,b,_,c) -> unirec_rec curenv  pb substn cM (subst1 b c)
+	    unirec_rec (push_rel_assum (na,t1) curenv) (prod_pb pb) true
+	      (unirec_rec curenv topconv true substn t1 t2) c1 c2
+	| LetIn (_,a,_,c), _ -> unirec_rec curenv pb b substn (subst1 a c) cN
+	| _, LetIn (_,a,_,c) -> unirec_rec curenv pb b substn cM (subst1 a c)
 	    
+	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
+            array_fold_left2 (unirec_rec curenv topconv true)
+	      (unirec_rec curenv topconv true
+		  (unirec_rec curenv topconv true substn p1 p2) c1 c2) cl1 cl2
+
 	| App (f1,l1), _ when
-	    isMeta f1 & is_unification_pattern f1 l1 & not (dependent f1 cN) ->
+	    isMeta f1 & is_unification_pattern curenv f1 l1 &
+	    not (dependent f1 cN) ->
 	      solve_pattern_eqn_array curenv f1 l1 cN substn
 
 	| _, App (f2,l2) when
-	    isMeta f2 & is_unification_pattern f2 l2 & not (dependent f2 cM) ->
+	    isMeta f2 & is_unification_pattern curenv f2 l2 &
+	    not (dependent f2 cM) ->
 	      solve_pattern_eqn_array curenv f2 l2 cM substn
 
 	| App (f1,l1), App (f2,l2) ->
 	      let len1 = Array.length l1
 	      and len2 = Array.length l2 in
-              let (f1,l1,f2,l2) =
-		if len1 = len2 then (f1,l1,f2,l2)
-		else if len1 < len2 then
-		  let extras,restl2 = array_chop (len2-len1) l2 in 
-		    (f1, l1, appvect (f2,extras), restl2)
-		else 
-		  let extras,restl1 = array_chop (len1-len2) l1 in 
-		    (appvect (f1,extras), restl1, f2, l2) in
-		(try
-		    array_fold_left2 (unirec_rec curenv CONV)
-		      (unirec_rec curenv CONV substn f1 f2) l1 l2
-		  with ex when precatchable_exception ex ->
-		    trivial_unify pb substn cM cN)
-	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
-            array_fold_left2 (unirec_rec curenv CONV)
-	      (unirec_rec curenv CONV 
-		  (unirec_rec curenv CONV substn p1 p2) c1 c2) cl1 cl2
-	| _ -> trivial_unify pb substn cM cN
+	      (try
+		  let (f1,l1,f2,l2) =
+		    if len1 = len2 then (f1,l1,f2,l2)
+		    else if len1 < len2 then
+		      let extras,restl2 = array_chop (len2-len1) l2 in 
+		      (f1, l1, appvect (f2,extras), restl2)
+		    else 
+		      let extras,restl1 = array_chop (len1-len2) l1 in 
+		      (appvect (f1,extras), restl1, f2, l2) in
+		  let pb = ConvUnderApp (len1,len2) in
+		  array_fold_left2 (unirec_rec curenv topconv true)
+		    (unirec_rec curenv pb true substn f1 f2) l1 l2
+		with ex when precatchable_exception ex ->
+		  expand curenv pb b substn cM f1 l1 cN f2 l2)
+		
+	| _ -> 
+	    let (f1,l1) = 
+	      match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
+	    let (f2,l2) =
+	      match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
+	    expand curenv pb b substn cM f1 l1 cN f2 l2
+
+  and expand curenv pb b substn cM f1 l1 cN f2 l2 =
+    if trivial_unify pb substn cM cN then substn
+    else if b then
+      match expand_constant curenv flags f1 with
+      | Some c ->
+	  unirec_rec curenv pb b substn (whd_betaiotazeta (mkApp(c,l1))) cN
+      | None ->
+      match expand_constant curenv flags f2 with
+      | Some c ->
+	  unirec_rec curenv pb b substn cM (whd_betaiotazeta (mkApp(c,l2)))
+      | None ->
+      error_cannot_unify env sigma (cM,cN)
+    else
+      error_cannot_unify env sigma (cM,cN)
+
   in
     if (not(occur_meta m)) &&
-      (if mod_delta then is_fconv cv_pb env sigma m n else eq_constr m n)
+      (match flags.modulo_conv_on_closed_terms with
+	  Some flags ->
+	    is_trans_fconv (conv_pb_of cv_pb) flags env sigma m n
+	| None -> constr_cmp (conv_pb_of cv_pb) m n)
     then 
-      ([],[])
+      subst
     else 
-      let (mc,ec) = unirec_rec env cv_pb ([],[]) m n in
-	((*sort_eqns*) mc, (*sort_eqns*) ec)
+      unirec_rec env cv_pb conv_at_top subst m n
+
+let unify_0 = unify_0_with_initial_metas ([],[]) true
 
+let left = true
+let right = false
+
+let pop k = if k=0 then 0 else k-1
+
+let rec unify_with_eta keptside flags env sigma k1 k2 c1 c2 =
+  (* Reason up to limited eta-expansion: ci is allowed to start with ki lam *)
+  (* Question: try whd_betadeltaiota on ci if ki>0 ? *)
+  match kind_of_term c1, kind_of_term c2 with
+  | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
+      let env' = push_rel_assum (na,t1) env in
+      let metas,evars = unify_0 env sigma topconv flags t1 t2 in
+      let side,status,(metas',evars') =
+	unify_with_eta keptside flags env' sigma (pop k1) (pop k2) c1' c2'
+      in (side,status,(metas@metas',evars@evars'))
+  | (Lambda (na,t,c1'),_) when k2 > 0 ->
+      let env' = push_rel_assum (na,t) env in
+      let side = left in (* expansion on the right: we keep the left side *)
+      unify_with_eta side flags env' sigma (pop k1) (k2-1) 
+	c1' (mkApp (lift 1 c2,[|mkRel 1|]))
+  | (_,Lambda (na,t,c2')) when k1 > 0 ->
+      let env' = push_rel_assum (na,t) env in
+      let side = right in (* expansion on the left: we keep the right side *)
+      unify_with_eta side flags env' sigma (k1-1) (pop k2) 
+	(mkApp (lift 1 c1,[|mkRel 1|])) c2'
+  | _ ->
+      (keptside,ConvUpToEta(min k1 k2),
+       unify_0 env sigma topconv flags c1 c2)
+
+(* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'],
+   we now compute the problem on [u =? u'] and decide which of u or u' is kept
+
+   Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically
+   in the case u' <= ?n <= u)
+ *)
+
+let merge_instances env sigma flags st1 st2 c1 c2 =
+  match (opp_status st1, st2) with
+  | (UserGiven, ConvUpToEta n2) ->
+      unify_with_eta left flags env sigma 0 n2 c1 c2
+  | (ConvUpToEta n1, UserGiven) ->
+      unify_with_eta right flags env sigma n1 0 c1 c2
+  | (ConvUpToEta n1, ConvUpToEta n2) ->
+      let side = left (* arbitrary choice, but agrees with compatibility *) in
+      unify_with_eta side flags env sigma n1 n2 c1 c2
+  | ((IsSubType | ConvUpToEta _ | UserGiven as oppst1),
+     (IsSubType | ConvUpToEta _ | UserGiven)) ->
+      let res = unify_0 env sigma Cumul flags c2 c1 in
+      if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
+      else if st2=IsSubType or st1=UserGiven then (left, st1, res)
+      else (right, st2, res)
+  | ((IsSuperType | ConvUpToEta _ | UserGiven as oppst1),
+     (IsSuperType | ConvUpToEta _ | UserGiven)) ->
+      let res = unify_0 env sigma Cumul flags c1 c2 in
+      if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
+      else if st2=IsSuperType or st1=UserGiven then (left, st1, res)
+      else (right, st2, res)
+  | (IsSuperType,IsSubType) ->
+      (try (left, IsSubType, unify_0 env sigma Cumul flags c2 c1)
+       with _ -> (right, IsSubType, unify_0 env sigma Cumul flags c1 c2))
+  | (IsSubType,IsSuperType) ->
+      (try (left, IsSuperType, unify_0 env sigma Cumul flags c1 c2)
+       with _ -> (right, IsSuperType, unify_0 env sigma Cumul flags c2 c1))
 
 (* Unification
  *
@@ -208,7 +376,8 @@ let applyHead env evd n c  =
     else 
       match kind_of_term (whd_betadeltaiota env (evars_of evd) cty) with
         | Prod (_,c1,c2) ->
-            let (evd',evar) = Evarutil.new_evar evd env c1 in
+            let (evd',evar) = 
+	      Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in
 	    apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
 	| _ -> error "Apply_Head_Then"
   in 
@@ -218,94 +387,167 @@ let is_mimick_head f =
   match kind_of_term f with
       (Const _|Var _|Rel _|Construct _|Ind _) -> true
     | _ -> false
- 
+
+let pose_all_metas_as_evars env evd t =
+  let evdref = ref evd in
+  let rec aux t = match kind_of_term t with
+  | Meta mv ->
+      (match Evd.meta_opt_fvalue !evdref mv with
+       | Some ({rebus=c},_) -> c
+       | None ->
+        let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in
+        let ty = if mvs = Evd.Metaset.empty then ty else aux ty in
+        let ev = Evarutil.e_new_evar evdref env ~src:(dummy_loc,GoalEvar) ty in
+        evdref := meta_assign mv (ev,(ConvUpToEta 0,TypeNotProcessed)) !evdref;
+        ev)
+  | _ ->
+      map_constr aux t in
+  let c = aux t in
+  (* side-effect *)
+  (!evdref, c)
+
+let try_to_coerce env evd c cty tycon =
+  let j = make_judge c cty in
+  let (evd',j') = inh_conv_coerce_rigid_to dummy_loc env evd j tycon in
+  let (evd',b) = Evarconv.consider_remaining_unif_problems env evd' in
+  if b then
+    let evd' = Evd.map_metas_fvalue (nf_evar (evars_of evd')) evd' in
+    (evd',j'.uj_val)
+  else
+    error "Cannot solve unification constraints"
+
+let w_coerce_to_type env evd c cty mvty =
+  let evd,mvty = pose_all_metas_as_evars env evd mvty in
+  let tycon = mk_tycon_type mvty in
+  try try_to_coerce env evd c cty tycon
+  with e when precatchable_exception e ->
+    (* inh_conv_coerce_rigid_to should have reasoned modulo reduction 
+       but there are cases where it though it was not rigid (like in
+       fst (nat,nat)) and stops while it could have seen that it is rigid *)
+    let cty = Tacred.hnf_constr env (evars_of evd) cty in
+    try_to_coerce env evd c cty tycon
+
+let w_coerce env evd mv c =
+  let cty = get_type_of env (evars_of evd) c in
+  let mvty = Typing.meta_type evd mv in
+  w_coerce_to_type env evd c cty mvty
+
+let unify_to_type env evd flags c u =
+  let sigma = evars_of evd in
+  let c = refresh_universes c in
+  let t = get_type_of_with_meta env sigma (metas_of evd) c in
+  let t = Tacred.hnf_constr env sigma (nf_betaiota (nf_meta evd t)) in
+  let u = Tacred.hnf_constr env sigma u in
+  try unify_0 env sigma Cumul flags t u
+  with e when precatchable_exception e -> ([],[])
+
+let unify_type env evd flags mv c =
+  let mvty = Typing.meta_type evd mv in
+  if occur_meta mvty then
+    unify_to_type env evd flags c mvty
+  else ([],[])
+
+(* Move metas that may need coercion at the end of the list of instances *)
+
+let order_metas metas =
+  let rec order latemetas = function
+  | [] -> List.rev latemetas
+  | (_,_,(status,to_type) as meta)::metas ->
+      if to_type = CoerceToType then order (meta::latemetas) metas
+      else meta :: order latemetas metas
+  in order [] metas
+
+(* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *)
+
+let solve_simple_evar_eqn env evd ev rhs =
+  let evd,b = solve_simple_eqn Evarconv.evar_conv_x env evd (CONV,ev,rhs) in
+  if not b then error_cannot_unify env (evars_of evd) (mkEvar ev,rhs);
+  let (evd,b) = Evarconv.consider_remaining_unif_problems env evd in
+  if not b then error "Cannot solve unification constraints";
+  evd
+
 (* [w_merge env sigma b metas evars] merges common instances in metas
    or in evars, possibly generating new unification problems; if [b]
    is true, unification of types of metas is required *)
 
-let w_merge env with_types mod_delta metas evars evd =
-  let ty_metas = ref [] in
-  let ty_evars = ref [] in
-  let rec w_merge_rec evd metas evars =
-    match (evars,metas) with
-      | ([], []) -> evd
-
-      | ((lhs,rhs)::t, metas) ->
-      (match kind_of_term rhs with
-
-	| Meta k -> w_merge_rec evd ((k,lhs)::metas) t
-
-	| krhs ->
-        (match kind_of_term lhs with
-
-	  | Evar (evn,_ as ev) ->
-    	      if is_defined_evar evd ev then
-		let (metas',evars') =
-                  unify_0 env (evars_of evd) CONV mod_delta rhs lhs in
-		w_merge_rec evd (metas'@metas) (evars'@t)
-    	      else begin
-		let rhs' = 
-		  if occur_meta rhs then subst_meta metas rhs else rhs 
-		in
-		if occur_evar evn rhs' then
-                  error "w_merge: recursive equation";
-                match krhs with
-		  | App (f,cl) when is_mimick_head f ->
-		      (try 
-		        w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
-		      with ex when precatchable_exception ex ->
-                        let evd' =
-                          mimick_evar evd mod_delta f (Array.length cl) evn in
-			w_merge_rec evd' metas evars)
-                  | _ ->
-                      (* ensure tail recursion in non-mimickable case! *)
-		      w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
-	      end
-
-	  | _ -> anomaly "w_merge_rec"))
-
-      | ([], (mv,n)::t) ->
-    	  if meta_defined evd mv then
-            let (metas',evars') =
-              unify_0 env (evars_of evd) CONV mod_delta
-               (meta_fvalue evd mv).rebus n in
-            w_merge_rec evd (metas'@t) evars'
-    	  else
-            begin
-	      if with_types (* or occur_meta mvty *) then
-	        (let mvty = Typing.meta_type evd mv in
-		try 
-                  let sigma = evars_of evd in
-                  (* why not typing with the metamap ? *)
-		  let nty = Typing.type_of env sigma (nf_meta evd n) in
-		  let (mc,ec) = unify_0 env sigma CUMUL mod_delta nty mvty in
-                  ty_metas := mc @ !ty_metas;
-                  ty_evars := ec @ !ty_evars
-		with e when precatchable_exception e -> ());
-              let evd' = meta_assign mv n evd in
-	      w_merge_rec evd' t []
-            end
-
-  and mimick_evar evd mod_delta hdc nargs sp =
+let w_merge env with_types flags (metas,evars) evd =
+  let rec w_merge_rec evd metas evars eqns =
+
+    (* Process evars *)
+    match evars with
+    | ((evn,_ as ev),rhs)::evars' ->
+    	if is_defined_evar evd ev then
+	  let v = Evd.existential_value (evars_of evd) ev in
+	  let (metas',evars'') =
+	    unify_0 env (evars_of evd) topconv flags rhs v in
+	  w_merge_rec evd (metas'@metas) (evars''@evars') eqns
+    	else begin
+          let rhs' = subst_meta_instances metas rhs in
+          match kind_of_term rhs with
+	  | App (f,cl) when is_mimick_head f & occur_meta rhs' ->
+	      if occur_evar evn rhs' then
+                error_occur_check env (evars_of evd) evn rhs';
+	      let evd' = mimick_evar evd flags f (Array.length cl) evn in
+	      w_merge_rec evd' metas evars eqns
+          | _ ->
+	      w_merge_rec (solve_simple_evar_eqn env evd ev rhs') 
+	        metas evars' eqns
+	  end
+    | [] -> 
+
+    (* Process metas *)
+    match metas with
+    | (mv,c,(status,to_type))::metas ->
+        let ((evd,c),(metas'',evars'')),eqns =
+	  if with_types & to_type <> TypeProcessed then
+	    if to_type = CoerceToType then
+              (* Some coercion may have to be inserted *)
+	      (w_coerce env evd mv c,([],[])),[]
+	    else
+              (* No coercion needed: delay the unification of types *)
+	      ((evd,c),([],[])),(mv,c)::eqns
+	  else 
+	    ((evd,c),([],[])),eqns in
+    	if meta_defined evd mv then
+	  let {rebus=c'},(status',_) = meta_fvalue evd mv in
+          let (take_left,st,(metas',evars')) =
+	    merge_instances env (evars_of evd) flags status' status c' c
+	  in
+	  let evd' = 
+            if take_left then evd 
+            else meta_reassign mv (c,(st,TypeProcessed)) evd 
+	  in
+          w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns
+    	else
+	  let evd' = meta_assign mv (c,(status,TypeProcessed)) evd in
+	  w_merge_rec evd' (metas@metas'') evars'' eqns
+    | [] -> 
+
+    (* Process type eqns *)
+    match eqns with
+    | (mv,c)::eqns ->
+        let (metas,evars) = unify_type env evd flags mv c in 
+        w_merge_rec evd metas evars eqns
+    | [] -> evd
+		
+  and mimick_evar evd flags hdc nargs sp =
     let ev = Evd.find (evars_of 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 (mc,ec) =
-      unify_0 sp_env (evars_of evd') CUMUL mod_delta
+      unify_0 sp_env (evars_of evd') Cumul flags
         (Retyping.get_type_of sp_env (evars_of evd') c) ev.evar_concl in
-    let evd'' = w_merge_rec evd' mc ec in
+    let evd'' = w_merge_rec evd' mc ec [] in
     if (evars_of evd') == (evars_of evd'')
     then Evd.evar_define sp c evd''
     else Evd.evar_define sp (Evarutil.nf_evar (evars_of evd'') c) evd'' in
 
   (* merge constraints *)
-  let evd' = w_merge_rec evd metas evars in
-  if with_types then
-    (* merge constraints about types: if they fail, don't worry *)
-    try w_merge_rec evd' !ty_metas !ty_evars
-    with e when precatchable_exception e -> evd'
-  else
-    evd'
+  w_merge_rec evd (order_metas metas) evars []
+
+let w_unify_meta_types env ?(flags=default_unify_flags) evd =
+  let metas,evd = retract_coercible_metas evd in
+  w_merge env true flags (metas,[]) evd
 
 (* [w_unify env evd M N]
    performs a unification of M and N, generating a bunch of
@@ -317,9 +559,22 @@ let w_merge env with_types mod_delta metas evars evd =
    [clenv_typed_unify M N clenv] expects in addition that expected
    types of metavars are unifiable with the types of their instances    *)
 
-let w_unify_core_0 env with_types cv_pb mod_delta m n evd =
-  let (mc,ec) = unify_0 env (evars_of evd) cv_pb mod_delta m n in 
-  w_merge env with_types mod_delta mc ec evd
+let check_types env evd subst m n =
+  if isEvar (fst (whd_stack m)) or isEvar (fst (whd_stack n)) then
+    unify_0_with_initial_metas subst true env (evars_of evd) topconv 
+      default_unify_flags
+      (Retyping.get_type_of_with_meta env (evars_of evd) (metas_of evd) m)
+      (Retyping.get_type_of_with_meta env (evars_of evd) (metas_of evd) n)
+  else
+    subst
+
+let w_unify_core_0 env with_types cv_pb flags m n evd =
+  let (mc1,evd') = retract_coercible_metas evd in
+  let subst1 = check_types env evd (mc1,[]) m n in
+  let subst2 =
+     unify_0_with_initial_metas subst1 true env (evars_of evd') cv_pb flags m n
+  in 
+  w_merge env with_types flags subst2 evd'
 
 let w_unify_0 env = w_unify_core_0 env false
 let w_typed_unify env = w_unify_core_0 env true
@@ -341,12 +596,12 @@ let iter_fail f a =
 (* Tries to find an instance of term [cl] in term [op].
    Unifies [cl] to every subterm of [op] until it finds a match.
    Fails if no match is found *)
-let w_unify_to_subterm env ?(mod_delta=true) (op,cl) evd =
+let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd =
   let rec matchrec cl =
     let cl = strip_outer_cast cl in
     (try 
        if closed0 cl 
-       then w_unify_0 env CONV mod_delta op cl evd,cl
+       then w_unify_0 env topconv flags op cl evd,cl
        else error "Bound 1"
      with ex when precatchable_exception ex ->
        (match kind_of_term cl with 
@@ -396,9 +651,9 @@ let w_unify_to_subterm env ?(mod_delta=true) (op,cl) evd =
   in 
   try matchrec cl
   with ex when precatchable_exception ex ->
-    raise (PretypeError (env,NoOccurrenceFound op))
+    raise (PretypeError (env,NoOccurrenceFound (op, None)))
 
-let w_unify_to_subterm_list env mod_delta allow_K oplist t evd = 
+let w_unify_to_subterm_list env flags allow_K oplist t evd = 
   List.fold_right 
     (fun op (evd,l) ->
       if isMeta op then
@@ -408,7 +663,7 @@ let w_unify_to_subterm_list env mod_delta allow_K oplist t evd =
         let (evd',cl) =
           try 
 	    (* This is up to delta for subterms w/o metas ... *)
-	    w_unify_to_subterm env ~mod_delta (strip_outer_cast op,t) evd
+	    w_unify_to_subterm env ~flags (strip_outer_cast op,t) evd
           with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op)
         in 
 	(evd',cl::l)
@@ -416,37 +671,37 @@ let w_unify_to_subterm_list env mod_delta allow_K oplist t evd =
 	(evd,op::l)
       else
 	(* This is not up to delta ... *)
-	raise (PretypeError (env,NoOccurrenceFound op)))
+	raise (PretypeError (env,NoOccurrenceFound (op, None))))
     oplist 
     (evd,[])
 
-let secondOrderAbstraction env mod_delta allow_K typ (p, oplist) evd =
-  let sigma = evars_of evd in
+let secondOrderAbstraction env flags allow_K typ (p, oplist) evd =
+  (* Remove delta when looking for a subterm *)
+  let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in
   let (evd',cllist) =
-    w_unify_to_subterm_list env mod_delta allow_K oplist typ evd in
+    w_unify_to_subterm_list env flags allow_K oplist typ evd in
   let typp = Typing.meta_type evd' p in
-  let pred = abstract_list_all env sigma typp typ cllist in
-  w_unify_0 env CONV mod_delta (mkMeta p) pred evd'
+  let pred = abstract_list_all env evd' typp typ cllist in
+  w_merge env false flags ([p,pred,(ConvUpToEta 0,TypeProcessed)],[]) evd'
 
-let w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd =
+let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
   let c1, oplist1 = whd_stack ty1 in
   let c2, oplist2 = whd_stack ty2 in
   match kind_of_term c1, kind_of_term c2 with
     | Meta p1, _ ->
         (* Find the predicate *)
 	let evd' =
-          secondOrderAbstraction env mod_delta allow_K ty2 (p1,oplist1) evd in 
+          secondOrderAbstraction env flags allow_K ty2 (p1,oplist1) evd in 
         (* Resume first order unification *)
-	w_unify_0 env cv_pb mod_delta (nf_meta evd' ty1) ty2 evd'
+	w_unify_0 env cv_pb flags (nf_meta evd' ty1) ty2 evd'
     | _, Meta p2 ->
         (* Find the predicate *)
 	let evd' =
-          secondOrderAbstraction env mod_delta allow_K ty1 (p2, oplist2) evd in 
+          secondOrderAbstraction env flags allow_K ty1 (p2, oplist2) evd in 
         (* Resume first order unification *)
-	w_unify_0 env cv_pb mod_delta ty1 (nf_meta evd' ty2) evd'
+	w_unify_0 env cv_pb flags ty1 (nf_meta evd' ty2) evd'
     | _ -> error "w_unify2"
 
-
 (* The unique unification algorithm works like this: If the pattern is
    flexible, and the goal has a lambda-abstraction at the head, then
    we do a first-order unification.
@@ -467,7 +722,8 @@ let w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd =
    Before, second-order was used if the type of Meta(1) and [x:A]t was
    convertible and first-order otherwise. But if failed if e.g. the type of
    Meta(1) had meta-variables in it. *)
-let w_unify allow_K env cv_pb ?(mod_delta=true) ty1 ty2 evd =
+let w_unify allow_K env cv_pb ?(flags=default_unify_flags) ty1 ty2 evd =
+  let cv_pb = of_conv_pb cv_pb in
   let hd1,l1 = whd_stack ty1 in
   let hd2,l2 = whd_stack ty2 in
     match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
@@ -475,25 +731,22 @@ let w_unify allow_K env cv_pb ?(mod_delta=true) ty1 ty2 evd =
       | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
 	  when List.length l1 = List.length l2 ->
 	  (try 
-	      w_typed_unify env cv_pb mod_delta ty1 ty2 evd
+	      w_typed_unify env cv_pb flags ty1 ty2 evd
 	    with ex when precatchable_exception ex -> 
 	      try 
-		w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
-	      with PretypeError (env,NoOccurrenceFound c) as e -> raise e
-		| ex when precatchable_exception ex -> 
-		    error "Cannot solve a second-order unification problem")
+		w_unify2 env flags allow_K cv_pb ty1 ty2 evd
+	      with PretypeError (env,NoOccurrenceFound _) as e -> raise e)
 	    
       (* Second order case *)
       | (Meta _, true, _, _ | _, _, Meta _, true) -> 
 	  (try 
-	      w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
-	    with PretypeError (env,NoOccurrenceFound c) as e -> raise e
+	      w_unify2 env flags allow_K cv_pb ty1 ty2 evd
+	    with PretypeError (env,NoOccurrenceFound _) as e -> raise e
 	      | ex when precatchable_exception ex -> 
 		  try 
-		    w_typed_unify env cv_pb mod_delta ty1 ty2 evd
-		  with ex when precatchable_exception ex -> 
-		    error "Cannot solve a second-order unification problem")
+		    w_typed_unify env cv_pb flags ty1 ty2 evd
+		  with ex' when precatchable_exception ex' ->
+		    raise ex)
 	    
       (* General case: try first order *)
-      | _ -> w_unify_0 env cv_pb mod_delta ty1 ty2 evd
-
+      | _ -> w_typed_unify env cv_pb flags ty1 ty2 evd
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 6be530be..89280631 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unification.mli 6142 2004-09-27 19:33:01Z sacerdot $ i*)
+(*i $Id: unification.mli 10856 2008-04-27 16:15:34Z herbelin $ i*)
 
 (*i*)
 open Term
@@ -14,20 +14,36 @@ open Environ
 open Evd
 (*i*)
 
+type unify_flags = { 
+  modulo_conv_on_closed_terms : Names.transparent_state option; 
+  use_metas_eagerly : bool;
+  modulo_delta : Names.transparent_state;
+}
+
+val default_unify_flags : unify_flags
+val default_no_delta_unify_flags : unify_flags
+
 (* The "unique" unification fonction *)
 val w_unify :
-  bool -> env -> conv_pb -> ?mod_delta:bool -> constr -> constr -> evar_defs -> evar_defs
+  bool -> env -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_defs -> evar_defs
 
 (* [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
    subterm of [t]. Constraints are added to [m] and the matched
    subterm of [t] is also returned. *)
 val w_unify_to_subterm :
-  env -> ?mod_delta:bool -> constr * constr -> evar_defs -> evar_defs * constr
+  env -> ?flags:unify_flags -> constr * constr -> evar_defs -> evar_defs * constr
+
+val w_unify_meta_types : env -> ?flags:unify_flags -> evar_defs -> evar_defs
+
+(* [w_coerce_to_type env evd c ctyp typ] tries to coerce [c] of type
+   [ctyp] so that its gets type [typ]; [typ] may contain metavariables *)
+val w_coerce_to_type : env -> evar_defs -> constr -> types -> types ->
+  evar_defs * constr
 
 (*i This should be in another module i*)
 
-(* [abstract_list_all env sigma t c l]                     *)
+(* [abstract_list_all env evd t c l]                       *)
 (* abstracts the terms in l over c to get a term of type t *)
 (* (exported for inv.ml) *)
 val abstract_list_all :
-  env -> evar_map -> constr -> constr -> constr list -> constr
+  env -> evar_defs -> constr -> constr -> constr list -> constr
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 46d67406..465c062b 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: vnorm.ml 11017 2008-05-29 13:00:24Z barras $ i*)
+
 open Names
 open Declarations
 open Term
@@ -52,14 +62,28 @@ let type_constructor mind mib typ params =
     let _,ctyp = decompose_prod_n nparams ctyp in   
     substl (List.rev (Array.to_list params)) ctyp
 
+
+
 let construct_of_constr const env tag typ =
   let (mind,_ as ind), allargs = find_rectype_a env typ in
-  let mib,mip = lookup_mind_specif env ind in
-  let nparams = mib.mind_nparams in
-  let i = invert_tag const tag mip.mind_reloc_tbl in
-  let params = Array.sub allargs 0 nparams in
-  let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
-  (mkApp(mkConstruct(ind,i), params), ctyp)
+  (* spiwack : here be a branch for specific decompilation handled by retroknowledge *)
+  try
+    if const then
+      ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (Ind ind) tag),
+       typ) (*spiwack: this may need to be changed in case there are parameters in the
+	               type which may cause a constant value to have an arity.
+	               (type_constructor seems to be all about parameters actually)
+	               but it shouldn't really matter since constant values don't use
+	               their ctyp in the rest of the code.*)
+    else
+      raise Not_found (* No retroknowledge function (yet) for block decompilation *)
+  with Not_found ->
+    let mib,mip = lookup_mind_specif env ind in
+    let nparams = mib.mind_nparams in
+    let i = invert_tag const tag mip.mind_reloc_tbl in
+    let params = Array.sub allargs 0 nparams in
+    let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
+      (mkApp(mkConstruct(ind,i), params), ctyp)
 
 let construct_of_constr_const env tag typ = 
   fst (construct_of_constr true env tag typ)
@@ -196,7 +220,8 @@ and nf_predicate env ind mip params v pT =
       let name = Name (id_of_string "c") in
       let n = mip.mind_nrealargs in
       let rargs = Array.init n (fun i -> mkRel (n-i)) in
-      let dom = mkApp(mkApp(mkInd ind,params),rargs) in
+      let params = if n=0 then params else Array.map (lift n) params in
+      let dom = mkApp(mkInd ind,Array.append params rargs) in
       let body = nf_vtype (push_rel (name,None,dom) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type