Imported Upstream version 8.0pl1upstream/8.0pl1

45 files changed, 12166 insertions, 0 deletions

diff --git a/pretyping/cases.ml b/pretyping/cases.ml
new file mode 100644
index 00000000..2126f015
--- /dev/null
+++ b/pretyping/cases.ml
@@ -0,0 +1,1773 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: cases.ml,v 1.111.2.1 2004/07/16 19:30:43 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductiveops
+open Environ
+open Sign
+open Reductionops
+open Typeops
+open Type_errors
+
+open Rawterm
+open Retyping
+open Pretype_errors
+open Evarutil
+open Evarconv
+
+(* Pattern-matching errors *)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+let raise_pattern_matching_error (loc,ctx,te) =
+  Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te))
+
+let error_bad_pattern_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind))
+
+let error_bad_constructor_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
+
+let error_wrong_numarg_constructor_loc loc c n =
+  raise_pattern_matching_error (loc, Global.env(), WrongNumargConstructor (c,n))
+
+let error_wrong_predicate_arity_loc loc env c n1 n2 =
+  raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
+
+let error_needs_inversion env x t =
+  raise (PatternMatchingError (env, NeedsInversion (x,t)))
+
+(*********************************************************************)
+(* A) Typing old cases                                               *)
+(* This was previously in Indrec but creates existential holes       *)
+
+let mkExistential isevars env loc = new_isevar isevars env loc (new_Type ())
+
+let norec_branch_scheme env isevars cstr =
+  let rec crec env = function
+    | d::rea -> mkProd_or_LetIn d (crec (push_rel d env) rea)
+    | [] -> mkExistential isevars env (dummy_loc, InternalHole) in 
+  crec env (List.rev cstr.cs_args)
+
+let rec_branch_scheme env isevars (sp,j) recargs cstr =
+  let rec crec env (args,recargs) = 
+    match args, recargs with 
+      | (name,None,c as d)::rea,(ra::reca) -> 
+	  let d =
+ 	    match dest_recarg ra with 
+	      | Mrec k when k=j ->
+		  let t = mkExistential isevars env (dummy_loc, InternalHole)
+		  in
+		  mkArrow t
+		    (crec (push_rel (Anonymous,None,t) env)
+		       (List.rev (lift_rel_context 1 (List.rev rea)),reca))
+              | _ -> crec (push_rel d env) (rea,reca) in
+          mkProd (name,  c, d)
+
+      | (name,Some b,c as d)::rea, reca -> 
+	  mkLetIn (name,b, c,crec (push_rel d env) (rea,reca))
+      | [],[] -> mkExistential isevars env (dummy_loc, InternalHole)
+      | _ -> anomaly "rec_branch_scheme"
+  in 
+  crec env (List.rev cstr.cs_args,recargs) 
+    
+let branch_scheme env isevars isrec indf =
+  let (ind,params) = dest_ind_family indf in
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let cstrs = get_constructors env indf in 
+  if isrec then
+    array_map2
+      (rec_branch_scheme env isevars ind)
+      (dest_subterms mip.mind_recargs) cstrs
+  else 
+    Array.map (norec_branch_scheme env isevars) cstrs
+
+(******************************************************)
+(* B) Building ML like case expressions without types *)
+
+let concl_n env sigma = 
+  let rec decrec m c = if m = 0 then (nf_evar sigma c) else 
+    match kind_of_term (whd_betadeltaiota env sigma c) with
+      | Prod (n,_,c_0) -> decrec (m-1) c_0
+      | _                -> failwith "Typing.concl_n"
+  in 
+  decrec
+
+let count_rec_arg j = 
+  let rec crec i = function 
+    | [] -> i 
+    | ra::l ->
+        (match dest_recarg ra with
+            Mrec k -> crec (if k=j then (i+1) else i) l
+          | _ -> crec i l)
+  in 
+  crec 0
+
+(* if arity of mispec is (p_bar:P_bar)(a_bar:A_bar)s where p_bar are the
+ * K parameters. Then then build_notdep builds the predicate
+ * [a_bar:A'_bar](lift k pred) 
+ * where A'_bar = A_bar[p_bar <- globargs] *)
+
+let build_dep_pred env sigma indf pred =
+  let arsign,_ = get_arity env indf in
+  let psign = (Anonymous,None,build_dependent_inductive env indf)::arsign in
+  let nar = List.length psign in
+  it_mkLambda_or_LetIn_name env (lift nar pred) psign
+
+type ml_case_error =
+  | MlCaseAbsurd
+  | MlCaseDependent
+
+exception NotInferable of ml_case_error
+
+
+let pred_case_ml env sigma isrec (IndType (indf,realargs)) (i,ft) =
+  let pred =
+    let (ind,params) = dest_ind_family indf in
+    let (mib,mip) = Inductive.lookup_mind_specif env ind in
+    let recargs = dest_subterms mip.mind_recargs in
+    if Array.length recargs = 0 then raise (NotInferable MlCaseAbsurd);
+    let recargi = recargs.(i) in
+    let j = snd ind in (* index of inductive *)
+    let nbrec = if isrec then count_rec_arg j recargi else 0 in
+    let nb_arg = List.length (recargs.(i)) + nbrec in
+    let pred = Evarutil.refresh_universes (concl_n env sigma nb_arg ft) in
+    if noccur_between 1 nb_arg pred then 
+      lift (-nb_arg) pred
+    else 
+      raise (NotInferable MlCaseDependent)
+  in
+  build_dep_pred env sigma indf pred  
+
+(************************************************************************)
+(*            Pattern-matching compilation (Cases)                      *)
+(************************************************************************)
+
+(************************************************************************)
+(* Configuration, errors and warnings *)
+
+open Pp
+
+let mssg_may_need_inversion () =
+  str "This pattern-matching is not exhaustive."
+
+let mssg_this_case_cannot_occur () =
+  "This pattern-matching is not exhaustive."
+
+(* Utils *)
+let make_anonymous_patvars =
+  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
+
+(* Environment management *)
+let push_rels vars env = List.fold_right push_rel vars env
+
+let push_rel_defs =
+  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
+
+(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
+   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
+
+let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
+
+let rec regeneralize_index i k t = match kind_of_term t with
+  | Rel j when j = i+k -> mkRel (k+1)
+  | Rel j when j < i+k -> t
+  | Rel j when j > i+k -> t
+  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
+
+type alias_constr =
+  | DepAlias
+  | NonDepAlias
+
+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));
+    uj_type = subst1 deppat j.uj_type }
+
+(**********************************************************************)
+(* Structures used in compiling pattern-matching *)
+type 'a lifted = int * 'a
+
+let insert_lifted a = (0,a);;
+
+(* The pattern variables for [it] are in [user_ids] and the variables
+   to avoid are in [other_ids]. 
+*)
+
+type rhs =
+    { rhs_env    : env;
+      other_ids  : identifier list;
+      user_ids   : identifier list;
+      rhs_lift   : int;
+      it         : rawconstr }
+
+type equation =
+    { dependencies : constr lifted list;
+      patterns     : cases_pattern list; 
+      rhs          : rhs;
+      alias_stack  : name list;
+      eqn_loc      : loc;
+      used         : bool ref;
+      tag          : pattern_source }
+
+type matrix = equation list
+
+(* 1st argument of IsInd is the original ind before extracting the summary *)
+type tomatch_type =
+  | IsInd of types * inductive_type
+  | NotInd of constr option * types
+
+type tomatch_status =
+  | Pushed of ((constr * tomatch_type) * int list)
+  | 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 (n,dep,pred)] types a pushed term ([Pushed]), if dep is true,
+     the term is dependent, if n<>0 then the type of the pushed term is
+     necessarily 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 (int * bool) * 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 =
+  | AliasLeaf
+  | AliasConstructor of constructor
+
+type pattern_history =
+  | Top
+  | MakeAlias of alias_builder * pattern_continuation
+
+and pattern_continuation =
+  | Continuation of int * cases_pattern list * pattern_history
+  | Result of cases_pattern list
+
+let start_history n = Continuation (n, [], Top)
+
+let initial_history = function Continuation (_,[],Top) -> true | _ -> false
+
+let feed_history arg = function
+  | Continuation (n, l, h) when n>=1 ->
+      Continuation (n-1, arg :: l, h)
+  | Continuation (n, _, _) ->
+      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
+  | Result _ -> 
+      anomaly "Exhausted pattern history"
+
+(* This is for non exhaustive error message *)
+
+let rec rawpattern_of_partial_history args2 = function
+  | Continuation (n, args1, h) ->
+      let args3 = make_anonymous_patvars (n - (List.length args2)) in
+      build_rawpattern (List.rev_append args1 (args2@args3)) h
+  | Result pl -> pl
+
+and build_rawpattern args = function
+  | Top -> args
+  | MakeAlias (AliasLeaf, rh) ->
+      assert (args = []);
+      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+  | MakeAlias (AliasConstructor pci, rh) ->
+      rawpattern_of_partial_history
+	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
+
+let complete_history = rawpattern_of_partial_history []
+
+(* This is to build glued pattern-matching history and alias bodies *)
+
+let rec simplify_history = function
+  | Continuation (0, l, Top) -> Result (List.rev l)
+  | Continuation (0, l, MakeAlias (f, rh)) ->
+      let pargs = List.rev l in
+      let pat = match f with
+	| AliasConstructor pci ->
+	    PatCstr (dummy_loc,pci,pargs,Anonymous)
+	| AliasLeaf -> 
+	    assert (l = []);
+	    PatVar (dummy_loc, Anonymous) in
+      feed_history pat rh
+  | h -> h
+
+(* Builds a continuation expecting [n] arguments and building [ci] applied
+   to this [n] arguments *)
+
+let push_history_pattern n current cont =
+  Continuation (n, [], MakeAlias (current, cont))
+
+(* A pattern-matching problem has the following form:
+
+   env, isevars |- <pred> Cases tomatch of mat end
+
+  where tomatch is some sequence of "instructions" (t1  ... tn)
+
+  and mat is some matrix 
+   (p11 ... p1n -> rhs1)
+   (    ...            )
+   (pm1 ... pmn -> rhsm)
+
+  Terms to match: there are 3 kinds of instructions
+
+  - "Pushed" terms to match are typed in [env]; these are usually just
+    Rel(n) except for the initial terms given by user and typed in [env]
+  - "Abstract" instructions means an abstraction has to be inserted in the
+    current branch to build (this means a pattern has been detected dependent
+    in another one and generalisation is necessary to ensure well-typing)
+  - "Alias" instructions means an alias has to be inserted (this alias
+    is usually removed at the end, except when its type is not the
+    same as the type of the matched term from which it comes -
+    typically because the inductive types are "real" parameters)
+
+  Right-hand-sides:
+
+  They consist of a raw term to type in an environment specific to the
+  clause they belong to: the names of declarations are those of the
+  variables present in the patterns. Therefore, they come with their
+  own [rhs_env] (actually it is the same as [env] except for the names
+  of variables).
+
+*)
+type pattern_matching_problem =
+    { env      : env;
+      isevars  : evar_defs;
+      pred     : predicate_signature option;
+      tomatch  : tomatch_stack;
+      history  : pattern_continuation;
+      mat      : matrix;
+      caseloc  : loc;
+      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+
+(*--------------------------------------------------------------------------*
+ * A few functions to infer the inductive type from the patterns instead of *
+ * checking that the patterns correspond to the ind. type of the            *
+ * destructurated object. Allows type inference of examples like            *
+ *  [n]Cases n of O => true | _ => false end                                *
+ *--------------------------------------------------------------------------*)
+
+(* Computing the inductive type from the matrix of patterns *)
+
+let rec find_row_ind = function
+    [] -> None
+  | PatVar _ :: l -> find_row_ind l
+  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
+
+exception NotCoercible
+
+let inh_coerce_to_ind isevars env tmloc ty tyi =
+  let (mib,mip) = Inductive.lookup_mind_specif env tyi in
+  let (ntys,_) = splay_prod env (evars_of isevars) mip.mind_nf_arity in
+  let hole_source = match tmloc with 
+    | Some loc -> fun i -> (loc, TomatchTypeParameter (tyi,i))
+    | None -> fun _ -> (dummy_loc, InternalHole) in
+   let (_,evarl,_) =
+    List.fold_right
+      (fun (na,ty) (env,evl,n) ->
+	 (push_rel (na,None,ty) env,
+	    (new_isevar isevars env (hole_source n) ty)::evl,n+1))
+      ntys (env,[],1) in
+  let expected_typ = applist (mkInd tyi,evarl) in
+     (* devrait être indifférent d'exiger leq ou pas puisque pour 
+        un inductif cela doit être égal *)
+  if the_conv_x_leq env isevars expected_typ ty then ty
+  else raise NotCoercible
+
+(* We do the unification for all the rows that contain
+ * constructor patterns. This is what we do at the higher level of patterns.
+ * For nested patterns, we do this unif when we ``expand'' the matrix, and we
+ * use the function above.
+ *)
+
+let unify_tomatch_with_patterns isevars env tmloc typ = function
+  | Some (cloc,(cstr,_ as c)) ->
+      (let tyi = inductive_of_constructor c in
+       try 
+	 let indtyp = inh_coerce_to_ind isevars env tmloc typ tyi in
+	 IsInd (typ,find_rectype env (evars_of isevars) typ)
+       with NotCoercible ->
+	 (* 2 cases : Not the right inductive or not an inductive at all *)
+	 try
+	   IsInd (typ,find_rectype env (evars_of isevars) typ)
+             (* will try to coerce later in check_and_adjust_constructor.. *)
+	 with Not_found ->
+	   NotInd (None,typ))
+	     (* error will be detected in check_all_variables *)
+  | None -> 
+      try IsInd (typ,find_rectype env (evars_of isevars) typ)
+      with Not_found -> NotInd (None,typ)
+
+let coerce_row typing_fun isevars env cstropt tomatch =
+  let j = typing_fun empty_tycon env tomatch in
+  let typ = body_of_type j.uj_type in
+  let loc = loc_of_rawconstr tomatch in
+  let t = unify_tomatch_with_patterns isevars env (Some loc) typ cstropt in
+  (j.uj_val,t)
+
+let coerce_to_indtype typing_fun isevars env matx tomatchl =
+  let pats = List.map (fun r ->  r.patterns) matx in
+  let matx' = match matrix_transpose pats with
+    | [] -> List.map (fun _ -> None) tomatchl (* no patterns at all *)
+    | m -> List.map find_row_ind m in
+  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+
+(************************************************************************)
+(* Utils *)
+
+   (* 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 None t (find_row_ind tm)
+
+let type_of_tomatch = function
+  | IsInd (t,_) -> t
+  | NotInd (_,t) -> t
+
+let mkDeclTomatch na = function
+  | 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_app 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
+
+let lift_tomatch n ((current,typ),info) =
+  ((lift n current,lift_tomatch_type n typ),info)
+
+(**********************************************************************)
+(* Utilities on patterns *)
+
+let current_pattern eqn =
+  match eqn.patterns with
+    | pat::_ -> pat
+    | [] -> anomaly "Empty list of patterns"
+
+let alias_of_pat = function
+  | PatVar (_,name) -> name
+  | PatCstr(_,_,_,name) -> name
+
+let unalias_pat = function
+  | PatVar (c,name) as p ->
+      if name = Anonymous then p else PatVar (c,Anonymous)
+  | PatCstr(a,b,c,name) as p ->
+      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
+
+let remove_current_pattern eqn =
+  match eqn.patterns with
+    | pat::pats ->
+	{ eqn with
+	    patterns = pats;
+	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
+    | [] -> anomaly "Empty list of patterns"
+
+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 *)
+
+exception NotAdjustable
+
+let rec adjust_local_defs loc = function
+  | (pat :: pats, (_,None,_) :: decls) ->
+      pat :: adjust_local_defs loc (pats,decls)
+  | (pats, (_,Some _,_) :: decls) ->
+      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
+  | [], [] -> []
+  | _ -> raise NotAdjustable
+
+let check_and_adjust_constructor ind cstrs = function 
+  | PatVar _ as pat -> pat
+  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
+      (* Check it is constructor of the right type *)
+      let ind' = inductive_of_constructor cstr in
+      if ind' = ind then
+	(* Check the constructor has the right number of args *)
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	if List.length args = nb_args_constr then pat
+	else
+	  try 
+	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
+	    in PatCstr (loc, cstr, args', alias)
+	  with NotAdjustable ->
+	    error_wrong_numarg_constructor_loc loc cstr nb_args_constr
+      else
+	(* Try to insert a coercion *)
+	try
+	  Coercion.inh_pattern_coerce_to loc pat ind' ind
+	with Not_found -> 
+	  error_bad_constructor_loc loc cstr ind
+
+let check_all_variables typ mat =
+  List.iter
+    (fun eqn -> match current_pattern eqn with
+       | PatVar (_,id) -> ()
+       | PatCstr (loc,cstr_sp,_,_) ->
+	   error_bad_pattern_loc loc cstr_sp typ)
+    mat
+
+let check_unused_pattern env eqn =
+  if not !(eqn.used) then 
+    raise_pattern_matching_error
+      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
+
+let set_used_pattern eqn = eqn.used := true
+
+let extract_rhs pb =
+  match pb.mat with 
+    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
+    | eqn::_ ->
+	set_used_pattern eqn;
+	eqn.tag, eqn.rhs
+
+(**********************************************************************)
+(* Functions to deal with matrix factorization *)
+
+let occur_in_rhs na rhs =
+  match na with
+    | Anonymous -> false
+    | Name id -> occur_rawconstr id rhs.it
+
+let is_dep_patt 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 dependent_decl a = function
+  | (na,None,t) -> dependent a t
+  | (na,Some c,t) -> dependent a t || dependent a c
+
+(* Computing the matrix of dependencies *)
+
+(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
+   computes for declaration [k+1] in which of declarations in
+   [nextlist] (which corresponds to d(k+2)...dn) it depends;
+   declarations are expressed by index, e.g. in dependency list
+   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
+
+let rec find_dependency_list k n = function
+  | [] -> []
+  | (used,tdeps,d)::rest -> 
+      let deps = find_dependency_list k (n+1) rest in
+      if used && dependent_decl (mkRel n) d
+      then list_add_set (List.length rest + 1) (list_union deps tdeps)
+      else deps
+
+let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
+  let deps = find_dependency_list k 1 nextlist in
+  if is_dep_or_cstr_in_rhs || deps <> []
+  then (k-1,(true ,deps,d)::nextlist)
+  else (k-1,(false,[]  ,d)::nextlist)
+
+let find_dependencies_signature deps_in_rhs typs =
+  let k = List.length deps_in_rhs in
+  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
+  List.map (fun (_,deps,_) -> deps) l
+
+(******)
+
+(* A Pushed term to match has just been substituted by some
+   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
+   match 
+
+   - all terms to match and to push (dependent on t by definition)
+     must have (Rel depth) substituted by t and Rel's>depth lifted by n
+   - all pushed terms to match (non dependent on t by definition) must
+     be lifted by n
+
+  We start with depth=1
+*)
+
+let regeneralize_index_tomatch n =
+  let rec genrec depth = function
+  | [] -> []
+  | Pushed ((c,tm),l)::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 ->
+      Abstract (map_rel_declaration (regeneralize_index n depth) d)
+      ::(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 replace_tomatch n c =
+  let rec replrec depth = function
+  | [] -> []
+  | Pushed ((b,tm),l)::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 ->
+      Abstract (map_rel_declaration (replace_term n c depth) d)
+      ::(replrec (depth+1) rest) in
+  replrec 0
+
+let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
+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 ->
+      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)
+  | 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)
+  | Abstract d::rest ->
+      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
+   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
+   default variable [name] is expected to have which type?
+   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
+
+(************************************************************************)
+(* Some heuristics to get names for variables pushed in pb environment *)
+(* Typical requirement:
+
+   [Cases y of (S (S x)) => x | x => x end] should be compiled into
+   [Cases y of O => y | (S n) => Cases n of O => y | (S x) => x end end]
+
+   and [Cases y of (S (S n)) => n | n => n end] into 
+   [Cases y of O => y | (S n0) => Cases n0 of O => y | (S n) => n end end]
+
+  i.e. user names should be preserved and created names should not
+  interfere with user names *)
+
+let merge_name get_name obj = function
+  | Anonymous -> get_name obj
+  | na -> na
+
+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
+  (* If any, we prefer names used in pats, from top to bottom *)
+  let names2 = 
+    List.fold_right
+      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
+      eqns names1 in
+  (* Otherwise, we take names from the parameters of the constructor but
+     avoiding conflicts with user ids *)
+  let allvars =
+    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.other_ids) [] eqns in
+  let names4,_ =
+    List.fold_left2
+      (fun (l,avoid) d na ->
+	 let na =
+	   merge_name
+	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+	     d na 
+	 in
+         (na::l,(out_name na)::avoid))
+      ([],allvars) (List.rev sign) names2 in
+  names4
+
+(************************************************************************)
+(* Recovering names for variables pushed to the rhs' environment *)
+
+let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
+
+let push_rels_eqn sign eqn =
+  {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env} }
+
+let push_rels_eqn_with_names sign eqn =
+  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+  let sign = recover_alias_names alias_of_pat pats sign in
+  push_rels_eqn sign eqn
+
+let build_aliases_context env sigma names allpats pats =
+  (* pats is the list of bodies to push as an alias *)
+  (* They all are defined in env and we turn them into a sign *)
+  (* cuts in sign need to be done in allpats *)
+  let rec insert env sign1 sign2 n newallpats oldallpats = function
+    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
+        (* Anonymous leaves must be considered named and treated in the *)
+        (* next clause because they may occur in implicit arguments *)
+	insert env sign1 sign2
+	  n newallpats (List.map List.tl oldallpats) (pats,names)
+    | (deppat,nondeppat,d,t)::pats, na::names ->
+	let nondeppat = lift n nondeppat in
+	let deppat = lift n deppat in
+	let newallpats =
+	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
+	let oldallpats = List.map List.tl oldallpats in
+	let u = Retyping.get_type_of env sigma deppat in
+	let decl = (na,Some deppat,t) in
+	let a = (deppat,nondeppat,d,t) in
+	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
+	  newallpats oldallpats (pats,names)
+    | [], [] -> newallpats, sign1, sign2, env
+    | _ -> anomaly "Inconsistent alias and name lists" in
+  let allpats = List.map (fun x -> [x]) allpats
+  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
+
+let insert_aliases_eqn sign eqnnames alias_rest eqn =
+  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
+  { eqn with
+      alias_stack = alias_rest;
+      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 *)
+  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 = 
+    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
+  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
+  sign2, env, eqns
+
+(**********************************************************************)
+(* Functions to deal with elimination predicate *)
+
+exception Occur
+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 "Inference of annotation not yet implemented in this case" 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')
+
+
+(* Infering the predicate *)
+(*
+The problem to solve is the following:
+
+We match Gamma |- t : I(u01..u0q) against the following constructors:
+
+  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
+   ...
+  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
+
+Assume the types in the branches are the following
+
+  Gamma, x11...x1p1 |- branch1 : T1
+   ...
+  Gamma, xn1...xnpn |- branchn : Tn
+
+Assume the type of the global case expression is Gamma |- T
+
+The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
+the following n+1 equations:
+
+  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
+   ...
+  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
+  Gamma             |- (phi u01..u0q t)               =  T
+
+Some hints:
+
+- Clearly, if xij occurs in Ti, then, a "Cases z of (Ci xi1..xipi) => ..."
+  should be inserted somewhere in Ti.
+
+- If T is undefined, an easy solution is to insert a "Cases z of (Ci
+  xi1..xipi) => ..." in front of each Ti
+
+- Otherwise, T1..Tn and T must be step by step unified, if some of them
+  diverge, then try to replace the diverging subterm by one of y1..yq or z.
+
+- 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) (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 =
+  let (mis,_) = dest_ind_family indf in
+  (* 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}] Cases c of (existS a b)=>(a,b) end *)
+    let typs =
+      Array.map (local_strong (whd_betaevar empty_env (evars_of isevars))) typs
+    in
+    let eqns = array_map2 prepare_unif_pb typs cstrs in
+    (* First strategy: no dependencies at all *)
+(*    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 isevars env (loc, CasesType)
+    in
+    if array_for_all (fun (_,_,typ) -> the_conv_x_leq 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 ((nargs,dep as tm),pred) ->
+      let k' = nargs + (if dep then 1 else 0) in
+      PrLetIn (tm, map_predicate f (k+k') pred)
+
+let liftn_predicate n = map_predicate (liftn n)
+
+let lift_predicate n = liftn_predicate n 1
+
+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 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 ((0,dep),pred) ->
+      subst_predicate ([],if dep then Some cur else None) pred
+  | PrLetIn ((_,dep),pred) ->
+      (match typ with
+        | IsInd (_,IndType (_,realargs)) ->
+            subst_predicate (realargs,if dep 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
+
+(*****************************************************************************)
+(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
+(* and we want to abstract P over y:t(x) typed in the same context to get    *)
+(*                                                                           *)
+(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
+(*                                                                           *)
+(* 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 ((nargs,dep as tm),pred) ->
+      if not dep then anomaly "Undetected dependency";
+      let p = nargs + 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 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 ->
+      let d' = map_rel_declaration (lift (List.length l)) d' in
+      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
+  | PrLetIn ((0,dep),pred), Pushed ((cur,_),_)::tms ->
+      extract_predicate (if dep then cur::l else l) (pred,tms)
+  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
+      let l = List.rev realargs@l in
+      extract_predicate (if dep then cur::l else l) (pred,tms)
+  | PrCcl ccl, [] ->
+      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 ((nrealargs,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 k =
+        if nrealargs = 0 & n <> 1 then 
+          (* Real args were not considered *) if dep then n-1 else n
+        else
+          (* Real args are OK *) if dep then 0 else 1 in
+      let pred = lift_predicate 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
+  | Some (PrCcl _) -> false
+  | Some (PrProd _) ->
+      anomaly "known_dependent: can only be used when patterns remain"
+
+(* [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 = deps <> [] || alreadydep in
+  let pred = if dep then pred else lift_predicate (-1) pred in
+  (* There is no dependency in realargs for subpattern *)
+  (k-1, PrLetIn ((0,dep), pred))
+
+
+(*****************************************************************************)
+(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
+(*                                                                           *)
+(*  Gamma |- Cases Pushed(c:I(realargs)) rest of...end: pred                 *)
+(*                                                                           *)
+(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
+(* is considered. Assume each Ti is some Ii(argsi).                          *)
+(* We let e=Ci(x1,...,xn) and replace pred by                                *)
+(*                                                                           *)
+(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
+(*                                                                           *)
+(* s.t Gamma,x1'..xn' |- Cases Pushed(x1')..Pushed(xn') rest of...end: pred' *)
+(*                                                                           *)
+(*****************************************************************************)
+let specialize_predicate tomatchs deps cs = function
+  | (PrProd _ | PrCcl _) ->
+      anomaly "specialize_predicate: a matched pattern must be pushed"
+  | PrLetIn ((nrealargs,isdep),pred) ->
+      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
+      let k = nrealargs + (if isdep 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 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 (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 ())
+
+(************************************************************************)
+(* Sorting equations by constructor *)
+
+type inversion_problem =
+  (* the discriminating arg in some Ind and its order in Ind *)
+  | Incompatible of int * (int * int)
+  | Constraints of (int * constr) list
+
+let solve_constraints constr_info indt =
+  (* TODO *)
+  Constraints []
+
+let rec irrefutable env = function
+  | PatVar (_,name) -> true
+  | PatCstr (_,cstr,args,_) ->
+      let ind = inductive_of_constructor cstr in
+      let (_,mip) = Inductive.lookup_mind_specif env ind in
+      let one_constr = Array.length mip.mind_user_lc = 1 in
+      one_constr & List.for_all (irrefutable env) args
+
+let first_clause_irrefutable env = function
+  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
+  | _ -> false
+
+let group_equations pb mind current cstrs mat =
+  let mat =
+    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
+  let brs = Array.create (Array.length cstrs) [] in
+  let only_default = ref true in
+  let _ =
+    List.fold_right (* To be sure it's from bottom to top *)
+      (fun eqn () ->
+	 let rest = remove_current_pattern eqn in
+	 let pat = current_pattern eqn in
+	 match check_and_adjust_constructor mind cstrs pat with 
+	   | PatVar (_,name) -> 
+	       (* 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) as cstr),args,_) as pat ->
+	       (* This is a regular clause *)
+	       only_default := false;
+	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
+  (brs,!only_default)
+
+(************************************************************************)
+(* Here starts the pattern-matching compilation algorithm *)
+
+(* Abstracting over dependent subterms to match *)
+let rec generalize_problem pb current = 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 tomatch = lift_tomatch_stack 1 pb'.tomatch in
+      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
+      { pb with
+	  tomatch = Abstract d :: tomatch;
+          pred = option_app (generalize_predicate current i d) 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
+
+(* Building the sub-problem when all patterns are variables *)
+let shift_problem (current,t) pb =
+  {pb with
+     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
+     pred = option_app (specialize_predicate_var (current,t)) 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 =
+  (* 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 = []
+    then
+      NonDepAlias
+    else 
+      DepAlias
+  in
+  let partialci =
+    applist (mkConstruct const_info.cs_cstr, const_info.cs_params) in
+  let history = 
+    push_history_pattern const_info.cs_nargs
+      (AliasConstructor const_info.cs_cstr)
+      pb.history in
+
+  (* We find matching clauses *)
+  let cs_args = (*assums_of_rel_context*) 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))
+      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
+
+  (* The dependent term to subst in the types of the remaining UnPushed 
+     terms is relative to the current context enriched by topushs *)
+  let ci = build_dependent_constructor const_info in
+
+  (* We replace [(mkRel 1)] by its expansion [ci] *)
+  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
+  (* This is done in two steps : first from "Gamma |- tms" *)
+  (* into  "Gamma; typs; curalias |- tms" *)
+  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
+
+  let currents =
+    list_map2_i
+      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
+      1 typs' (List.rev dep_sign) in
+
+  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
+
+  let ind =
+    appvect (
+      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+      List.map (lift const_info.cs_nargs) const_info.cs_params),
+      const_info.cs_concl_realargs) in
+
+  let cur_alias = lift (List.length sign) current in
+  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
+
+  sign,
+  { pb with
+      env = push_rels sign pb.env;
+      tomatch = List.rev_append currents tomatch;
+      pred = option_app (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred;
+      history = history;
+      mat = List.map (push_rels_eqn_with_names sign) submat }
+
+(**********************************************************************
+ INVARIANT:
+
+  pb = { env, subst, tomatch, mat, ...}
+  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
+
+  "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.
+
+*)
+
+(**********************************************************************)
+(* Main compiling descent *)
+let rec compile pb =
+  match pb.tomatch with
+    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
+    | (Alias x)::rest -> compile_alias pb x rest
+    | (Abstract d)::rest -> compile_generalization pb d rest
+    | [] -> build_leaf pb
+
+and match_current pb ((current,typ as ct),deps) =
+  let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+  let (_,c,t) = mkDeclTomatch Anonymous typ in
+  let typ = to_mutind pb.env pb.isevars tm1 c t in
+  match typ with
+    | NotInd (_,typ) ->
+	check_all_variables typ pb.mat;
+	compile (shift_problem ct pb)
+    | IsInd (_,(IndType(indf,realargs) as indt)) ->
+	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
+	if (cstrs <> [||] or not (initial_history pb.history)) & onlydflt then
+	  compile (shift_problem ct pb)
+	else
+          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
+
+	  (* We compile branches *)
+	  let brs = array_map2 (compile_branch current 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 (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
+	  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_generalization pb d rest =
+  let pb =
+    { pb with
+       env = push_rel d pb.env;
+       tomatch = rest;
+       pred = option_app ungeneralize_predicate pb.pred;
+       mat = List.map (push_rels_eqn [d]) pb.mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  { 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 (evars_of pb.isevars) (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 *)
+  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
+  let tomatch = lift_tomatch_stack n rest in
+  let tomatch = match kind_of_term nondeppat with
+    | Rel i ->
+	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
+	else replace_tomatch i deppat tomatch
+    | _ -> (* initial terms are not dependent *) tomatch in
+
+  let pb =
+    {pb with
+       env = newenv;
+       tomatch = tomatch;
+       pred = option_app (lift_predicate n) pb.pred;
+       history = history;
+       mat = mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  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 *)
+
+(**************************************************************************)
+(* Preparation of the pattern-matching problem                            *)
+
+(* Qu'est-ce qui faut pas faire pour traiter les alias ... *)
+
+(* On ne veut pas ajouter de primitive à Environ et le problème, c'est
+   donc de faire un renommage en se contraignant à parcourir l'env
+   dans le sens croissant. Ici, subst renomme des variables repérées
+   par leur numéro et seen_ids collecte celles dont on sait que les
+   variables de subst annule le scope *)
+let rename_env subst env =
+  let n = ref (rel_context_length (rel_context env)) in
+  let seen_ids = ref [] in
+  process_rel_context
+    (fun (na,c,t as d) env ->
+       let d =
+	 try
+	   let id = List.assoc !n subst in
+	   seen_ids := id :: !seen_ids;
+	   (Name id,c,t)
+	 with Not_found ->
+	   match na with
+	     | Name id when List.mem id !seen_ids -> (Anonymous,c,t)
+	     | _ -> d in
+       decr n;
+       push_rel d env) env
+
+let is_dependent_indtype = function
+  | NotInd _ -> false
+  | IsInd (_, IndType(_,realargs)) -> List.length realargs <> 0
+
+let prepare_initial_alias_eqn isdep tomatchl eqn =
+  let (subst, pats) = 
+  List.fold_right2
+    (fun pat (tm,tmtyp) (subst, stripped_pats) ->
+       match alias_of_pat pat with
+	 | Anonymous -> (subst, pat::stripped_pats)
+	 | Name idpat as na ->
+	     match kind_of_term tm with
+	       | Rel n when not (is_dependent_indtype tmtyp) & not isdep
+		   -> (n, idpat)::subst, (unalias_pat pat::stripped_pats)
+	       | _ -> (subst, pat::stripped_pats))
+    eqn.patterns tomatchl ([], []) in
+  let env = rename_env subst eqn.rhs.rhs_env in
+  { eqn with patterns = pats; rhs = { eqn.rhs with rhs_env = env } }
+
+let prepare_initial_aliases isdep tomatchl mat = mat
+(*  List.map (prepare_initial_alias_eqn isdep tomatchl) mat*)
+
+(*
+let prepare_initial_alias lpat tomatchl rhs =
+  List.fold_right2
+    (fun pat tm (stripped_pats, rhs) ->
+       match alias_of_pat pat with
+	 | Anonymous -> (pat::stripped_pats, rhs)
+	 | Name _ as na ->
+	     match tm with
+	       | RVar _ -> 
+		   (unalias_pat pat::stripped_pats, 
+		    RLetIn (dummy_loc, na, tm, rhs))
+	       | _ -> (pat::stripped_pats, rhs))
+    lpat tomatchl ([], rhs)
+*)
+(* builds the matrix of equations testing that each eqn has n patterns
+ * and linearizing the _ patterns.
+ * Syntactic correctness has already been done in astterm *)
+let matx_of_eqns env tomatchl eqns =
+  let build_eqn (loc,ids,lpat,rhs) =
+(*    let initial_lpat,initial_rhs = prepare_initial_alias lpat tomatchl rhs in*)
+    let initial_lpat,initial_rhs = lpat,rhs in
+    let initial_rhs = rhs in
+    let rhs =
+      { rhs_env = env;
+	other_ids = ids@(ids_of_named_context (named_context env));
+	user_ids = ids;
+	rhs_lift = 0;
+	it = initial_rhs } in
+    { dependencies = [];
+      patterns = initial_lpat;
+      tag = RegularPat;
+      alias_stack = [];
+      eqn_loc = loc;
+      used = ref false;
+      rhs = rhs }
+  in List.map build_eqn eqns
+
+(************************************************************************)
+(* preparing the elimination predicate if any                          *)
+
+let build_expected_arity env isevars isdep tomatchl =
+  let cook n = function
+    | _,IsInd (_,IndType(indf,_)) ->
+        let indf' = lift_inductive_family n indf in
+	Some (build_dependent_inductive env indf', fst (get_arity env indf'))
+    | _,NotInd _ -> None
+  in
+  let rec buildrec n env = function
+    | [] -> new_Type ()
+    | tm::ltm ->
+	match cook n tm with
+	  | None -> buildrec n env ltm
+	  | Some (ty1,aritysign) ->
+	      let rec follow n env = function
+		| d::sign ->
+		    mkProd_or_LetIn_name env
+		      (follow (n+1) (push_rel d env) sign) d
+		| [] ->
+		    if isdep then
+		      mkProd (Anonymous, ty1, 
+			      buildrec (n+1)
+				(push_rel_assum (Anonymous, ty1) env)
+				ltm)
+		    else buildrec n env ltm
+	      in follow n env (List.rev aritysign)
+  in buildrec 0 env tomatchl
+
+let extract_predicate_conclusion isdep tomatchl pred =
+  let cook = function
+    | _,IsInd (_,IndType(_,args)) -> Some (List.length args)
+    | _,NotInd _ -> None in
+  let decomp_lam_force p =
+    match kind_of_term p with
+      | Lambda (_,_,c) -> c
+      | _ -> (* eta-expansion *) applist (lift 1 p, [mkRel 1]) in
+  let rec buildrec p = function
+    | [] -> p
+    | tm::ltm ->
+	match cook tm with
+	  | None -> 
+              let p = 
+                (* adjust to a sign containing the NotInd's *)
+                if isdep then lift 1 p else p in
+              buildrec p ltm 
+	  | Some n ->
+              let n = if isdep then n+1 else n in
+              let p = iterate decomp_lam_force n p in
+              buildrec p ltm
+  in buildrec pred tomatchl
+
+let set_arity_signature dep n arsign tomatchl pred x =
+  (* avoid is not exhaustive ! *)
+  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) -> 
+          decomp_lam_force (n-1) (id::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) 
+          (* eta-expansion *)
+            (let a = RVar (dummy_loc,x) in
+             match p with
+               | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+               | _ -> (RApp (dummy_loc,p,[a]))) in
+  let rec decomp_block avoid p = function
+    | ([], _) -> x := Some p
+    | ((_,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
+        let na,p,avoid' = 
+          if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid'
+        in 
+        y :=
+        (List.hd na,
+         if List.for_all ((=) Anonymous) nal then
+           None
+         else
+           Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal));
+        decomp_block avoid' p (l,l')
+    | (_::l),(y::l') ->
+        y := (Anonymous,None);
+        decomp_block avoid p (l,l')
+    | _ -> anomaly "set_arity_signature"
+  in
+  decomp_block [] pred (tomatchl,arsign)
+
+let prepare_predicate_from_tycon loc dep env isevars tomatchs c =
+  let cook (n, l, env) = function
+    | 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
+	if dep then
+	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env)
+	else
+	  (n + p, (List.rev realargs)@l, push_rels sign env)
+    | c,NotInd _ ->
+	(n, l, env) in
+  let n, allargs, env = List.fold_left cook (0, [], env) tomatchs in
+  let allargs =
+    List.map (fun c -> lift n (nf_betadeltaiota env (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
+      mkExistential isevars env (loc, CasesType)
+    else
+      map_constr_with_full_binders push_rel build_skeleton env c in
+  build_skeleton env (lift n c)
+  
+(* Here, [pred] is assumed to be in the context built from all *)
+(* realargs and terms to match *)
+let build_initial_predicate isdep pred tomatchl =
+  let nar = List.fold_left (fun n (_,t) ->
+    let p = match t with IsInd (_,IndType(_,a)) -> List.length a | _ -> 0 in
+    if isdep then n+p+1 else n+p) 0 tomatchl in
+  let cook = function
+    | _,IsInd (_,IndType(_,realargs)) -> List.length realargs
+    | _,NotInd _ -> 0 in
+  let rec buildrec n pred = function
+    | [] -> PrCcl pred
+    | tm::ltm ->
+        let nrealargs = cook tm 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
+	PrLetIn ((nrealargs,p=1), buildrec (n+nrealargs+user_p) pred ltm)
+  in buildrec 0 pred tomatchl
+
+let extract_arity_signature env0 tomatchl tmsign =
+  let get_one_sign n tm {contents = (na,t)} =
+    match tm with
+      | NotInd (bo,typ) -> 
+	  (match t with
+	    | None -> [na,option_app (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)) ->
+          let indf' = lift_inductive_family n indf in
+	  let (ind,params) = dest_ind_family indf' in
+	  let nrealargs = List.length realargs in
+	  let realnal =
+	    match t with
+	      | Some (loc,ind',nal) ->
+		  let nparams = List.length params in
+		  if ind <> ind' then
+		    user_err_loc (loc,"",str "Wrong inductive type");
+		  if List.length nal <> nparams + nrealargs then
+		    user_err_loc (loc,"",
+		    str "Wrong number of arguments for inductive type");
+		  let parnal,realnal = list_chop nparams nal in
+		  if List.exists ((<>) Anonymous) parnal then
+		    user_err_loc (loc,"",
+		    str "The parameters of inductive type must be implicit");
+		  List.rev realnal
+	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+	  let arsign = fst (get_arity env0 indf') 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
+    | [],[] -> []
+    | (_,tm)::ltm, x::tmsign ->
+	let l = get_one_sign n tm x in
+	(buildrec (n + List.length l) (ltm,tmsign)) @ l
+    | _ -> assert false
+  in buildrec 0 (tomatchl,tmsign)
+
+(* Builds the predicate. If the predicate is dependent, its context is
+ * made of 1+nrealargs assumptions for each matched term in an inductive
+ * type and 1 assumption for each term not _syntactically_ in an
+ * inductive type.
+
+ * V7 case: determines whether the multiple case is dependent or not
+ * - if its arity is made of nrealargs assumptions for each matched
+ * term in an inductive type and nothing for terms not _syntactically_
+ * in an inductive type, then it is non dependent
+ * - if its arity is made of 1+nrealargs assumptions for each matched
+ * term in an inductive type and nothing for terms not _syntactically_
+ * in an inductive type, then it is dependent and needs an adjustement
+ * to fulfill the criterion above that terms not in an inductive type
+ * counts for 1 in the dependent case
+
+ * V8 case: each matched terms are independently considered dependent
+ * or not
+
+ * A type constraint but no annotation case: it is assumed non dependent
+ *)
+
+let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function
+  (* No type annotation at all *)
+  | (None,{contents = None}) ->
+      (match tycon with
+       | None -> None
+       | Some t ->
+	 let pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in
+	 Some (build_initial_predicate false pred tomatchs))
+
+  (* v8 style type annotation *)
+  | (None,{contents = Some rtntyp}) ->
+
+      (* We extract the signature of the arity *)
+      let arsign = extract_arity_signature env tomatchs sign in
+      let env = push_rels arsign env in
+      let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in
+      Some (build_initial_predicate true predccl tomatchs)
+
+  (* v7 style type annotation; set the v8 annotation by side effect *)
+  | (Some pred,x) ->
+      let loc = loc_of_rawconstr pred in
+      let dep, n, predj =
+	let isevars_copy = evars_of isevars in
+        (* We first assume the predicate is non dependent *)
+	let ndep_arity = build_expected_arity env isevars false tomatchs in
+        try
+	  false, nb_prod ndep_arity, typing_fun (mk_tycon ndep_arity) env pred
+	with PretypeError _ | TypeError _ |
+	    Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
+        evars_reset_evd isevars_copy isevars;
+        (* We then assume the predicate is dependent *)
+	let dep_arity = build_expected_arity env isevars true tomatchs in
+	try
+	  true, nb_prod dep_arity, typing_fun (mk_tycon dep_arity) env pred
+	with PretypeError _ | TypeError _ |
+	  Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
+        evars_reset_evd isevars_copy isevars;
+        (* Otherwise we attempt to type it without constraints, possibly *)
+        (* failing with an error message; it may also be well-typed *)
+	(* but fails to satisfy arity constraints in case_dependent *)
+        let predj = typing_fun empty_tycon env pred in
+	error_wrong_predicate_arity_loc
+	  loc env predj.uj_val ndep_arity dep_arity
+      in
+      let predccl = extract_predicate_conclusion dep tomatchs predj.uj_val in
+(*
+      let etapred,cdep = case_dependent env (evars_of isevars) loc predj tomatchs in
+*)
+      set_arity_signature dep n sign tomatchs pred x;
+      Some (build_initial_predicate dep predccl tomatchs)
+
+
+(**************************************************************************)
+(* Main entry of the matching compilation                                 *)
+
+let compile_cases loc (typing_fun,isevars) 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 rawtms, tmsign = List.split tomatchl in
+  let tomatchs = coerce_to_indtype typing_fun isevars env matx rawtms in
+
+  (* We build the elimination predicate if any and check its consistency *)
+  (* with the type of arguments to match *)
+  let pred = prepare_predicate loc typing_fun isevars env tomatchs tmsign tycon predopt in
+
+  (* We deal with initial aliases *)
+  let matx = prepare_initial_aliases (known_dependent pred) tomatchs matx 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 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
+  
+  let _, j = compile pb in
+
+  (* We check for unused patterns *)
+  List.iter (check_unused_pattern env) matx;
+  
+  match tycon with
+    | Some p ->	Coercion.inh_conv_coerce_to loc env isevars j p
+    | None -> j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
new file mode 100644
index 00000000..1d2f9025
--- /dev/null
+++ b/pretyping/cases.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  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: cases.mli,v 1.22.2.2 2004/07/16 19:30:43 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Evd
+open Environ
+open Inductiveops
+open Rawterm
+open Evarutil
+(*i*)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+(*s Used for old cases in pretyping *)
+
+val branch_scheme : 
+  env -> evar_defs -> bool -> inductive_family -> constr array
+
+type ml_case_error =
+  | MlCaseAbsurd
+  | MlCaseDependent
+
+exception NotInferable of ml_case_error
+
+val pred_case_ml : (* raises [NotInferable] if not inferable *)
+  env -> evar_map -> bool -> inductive_type -> int * types -> constr 
+
+(*s Compilation of pattern-matching. *)
+
+val compile_cases :
+  loc -> (type_constraint -> env -> rawconstr -> unsafe_judgment)
+  * evar_defs -> type_constraint -> env ->
+      (rawconstr option * rawconstr option ref) *
+      (rawconstr * (name * (loc * inductive * name list) option) ref) list *
+    (loc * identifier list * cases_pattern list * rawconstr) list ->
+    unsafe_judgment
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
new file mode 100644
index 00000000..88f59ded
--- /dev/null
+++ b/pretyping/cbv.ml
@@ -0,0 +1,352 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: cbv.ml,v 1.12.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Term
+open Names
+open Environ
+open Instantiate
+open Univ
+open Evd
+open Closure
+open Esubst
+
+(**** Call by value reduction ****)
+
+(* The type of terms with closure. The meaning of the constructors and
+ * the invariants of this datatype are the following:
+ *  VAL(k,c) represents the constr c with a delayed shift of k. c must be
+ *          in normal form and neutral (i.e. not a lambda, a construct or a
+ *          (co)fix, because they may produce redexes by applying them,
+ *          or putting them in a case)
+ *  LAM(x,a,b,S) is the term [S]([x:a]b). the bindings is propagated
+ *          only when the abstraction is applied, and then we use the rule
+ *                  ([S]([x:a]b) c) --> [S.c]b
+ *          This corresponds to the usual strategy of weak reduction
+ *  FIXP(op,bd,S,args) is the fixpoint (Fix or Cofix) of bodies bd under
+ *          the bindings S, and then applied to args. Here again,
+ *          weak reduction.
+ *  CONSTR(c,args) is the constructor [c] applied to [args].
+ *
+ * Note that any term has not an equivalent in cbv_value: for example,
+ * a product (x:A)B must be in normal form because only VAL may
+ * represent it, and the argument of VAL is always in normal
+ * form. This remark precludes coding a head reduction with these
+ * functions. Anyway, does it make sense to head reduce with a
+ * call-by-value strategy ?
+ *)
+type cbv_value =
+  | VAL of int * constr
+  | LAM of name * constr * constr * cbv_value subs
+  | FIXP of fixpoint * cbv_value subs * cbv_value list
+  | COFIXP of cofixpoint * cbv_value subs * cbv_value list
+  | CONSTR of constructor * cbv_value list
+
+(* les vars pourraient etre des constr,
+   cela permet de retarder les lift: utile ?? *) 
+
+(* relocation of a value; used when a value stored in a context is expanded
+ * in a larger context. e.g.  [%k (S.t)](k+1) --> [^k]t  (t is shifted of k)
+ *)
+let rec shift_value n = function
+  | VAL (k,v) -> VAL ((k+n),v)
+  | LAM (x,a,b,s) -> LAM (x,a,b,subs_shft (n,s))
+  | FIXP (fix,s,args) ->
+      FIXP (fix,subs_shft (n,s), List.map (shift_value n) args)
+  | COFIXP (cofix,s,args) ->
+      COFIXP (cofix,subs_shft (n,s), List.map (shift_value n) args)
+  | CONSTR (c,args) ->
+      CONSTR (c, List.map (shift_value n) args)
+	
+
+(* Contracts a fixpoint: given a fixpoint and a bindings,
+ * returns the corresponding fixpoint body, and the bindings in which
+ * it should be evaluated: its first variables are the fixpoint bodies
+ * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1}))
+ *    -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti)
+ *)
+let contract_fixp env ((reci,i),(_,_,bds as bodies)) =
+  let make_body j = FIXP(((reci,j),bodies), env, []) in
+  let n = Array.length bds in
+  let rec subst_bodies_from_i i subs =
+    if i=n then subs
+    else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs))
+  in       
+  subst_bodies_from_i 0 env, bds.(i)
+
+let contract_cofixp env (i,(_,_,bds as bodies)) =
+  let make_body j = COFIXP((j,bodies), env, []) in
+  let n = Array.length bds in
+  let rec subst_bodies_from_i i subs =
+    if i=n then subs
+    else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs))
+  in       
+  subst_bodies_from_i 0 env, bds.(i)
+
+let make_constr_ref n = function
+  | FarRelKey p -> mkRel (n+p)
+  | VarKey id -> mkVar id
+  | ConstKey cst -> mkConst cst
+
+
+(* type of terms with a hole. This hole can appear only under App or Case.
+ *   TOP means the term is considered without context
+ *   APP(l,stk) means the term is applied to l, and then we have the context st
+ *      this corresponds to the application stack of the KAM.
+ *      The members of l are values: we evaluate arguments before the function.
+ *   CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk
+ *      t is the type of the case and br are the branches, all of them under
+ *      the subs S, pat is information on the patterns of the Case
+ *      (Weak reduction: we propagate the sub only when the selected branch
+ *      is determined)
+ *
+ * Important remark: the APPs should be collapsed:
+ *    (APP (l,(APP ...))) forbidden
+ *)
+
+type cbv_stack =
+  | TOP
+  | APP of cbv_value list * cbv_stack
+  | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
+
+(* Adds an application list. Collapse APPs! *)
+let stack_app appl stack =
+  match (appl, stack) with
+    | ([], _)            -> stack
+    | (_, APP(args,stk)) -> APP(appl@args,stk)
+    | _                  -> APP(appl, stack)
+
+
+open RedFlags
+
+let red_set_ref flags = function
+  | FarRelKey _ -> red_set flags fDELTA
+  | VarKey id -> red_set flags (fVAR id)
+  | ConstKey sp -> red_set flags (fCONST sp)
+
+(* Transfer application lists from a value to the stack
+ * useful because fixpoints may be totally applied in several times
+ *)
+let strip_appl head stack =
+  match head with
+    | FIXP (fix,env,app) -> (FIXP(fix,env,[]), stack_app app stack)
+    | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[]), stack_app app stack)
+    | CONSTR (c,app) -> (CONSTR(c,[]), stack_app app stack)
+    | _ -> (head, stack)
+
+
+(* Tests if fixpoint reduction is possible. A reduction function is given as
+   argument *)
+let rec check_app_constr = function
+  | ([], _) -> false
+  | ((CONSTR _)::_, 0) -> true
+  | (_::l, n) -> check_app_constr (l,(pred n))
+	
+let fixp_reducible flgs ((reci,i),_) stk =
+  if red_set flgs fIOTA then
+    match stk with               (* !!! for Acc_rec: reci.(i) = -2 *)
+      | APP(appl,_) -> reci.(i) >=0 & check_app_constr (appl, reci.(i))
+      | _ -> false
+  else 
+    false
+
+let cofixp_reducible flgs _ stk =
+  if red_set flgs fIOTA then
+    match stk with
+      | (CASE _ | APP(_,CASE _)) -> true
+      | _ -> false
+  else 
+    false
+
+(* The main recursive functions
+ *
+ * Go under applications and cases (pushed in the stack), expand head
+ * constants or substitued de Bruijn, and try to make appear a
+ * constructor, a lambda or a fixp in the head. If not, it is a value
+ * and is completely computed here. The head redexes are NOT reduced:
+ * the function returns the pair of a cbv_value and its stack.  *
+ * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last
+ * argument is [].  Because we must put all the applied terms in the
+ * stack. *)
+
+let rec norm_head info env t stack =
+  (* no reduction under binders *)
+  match kind_of_term t with
+  (* stack grows (remove casts) *)
+  | App (head,args) -> (* Applied terms are normalized immediately;
+                        they could be computed when getting out of the stack *)
+      let nargs = Array.map (cbv_stack_term info TOP env) args in
+      norm_head info env head (stack_app (Array.to_list nargs) stack)
+  | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack))
+  | Cast (ct,_) -> norm_head info env ct stack
+
+  (* constants, axioms
+   * the first pattern is CRUCIAL, n=0 happens very often:
+   * when reducing closed terms, n is always 0 *)
+  | Rel i ->
+      (match expand_rel i env with
+        | Inl (0,v)      -> strip_appl v stack
+        | Inl (n,v)      -> strip_appl (shift_value n v) stack
+        | Inr (n,None)   -> (VAL(0, mkRel n), stack)
+        | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (FarRelKey p))
+
+  | Var id -> norm_head_ref 0 info env stack (VarKey id)
+
+  | Const sp -> norm_head_ref 0 info env stack (ConstKey sp)
+
+  | LetIn (x, b, t, c) ->
+      (* zeta means letin are contracted; delta without zeta means we *)
+      (* allow bindings but leave let's in place *)
+      let zeta = red_set (info_flags info) fZETA in
+      let env' =
+	if zeta 
+          (* New rule: for Cbv, Delta does not apply to locally bound variables
+          or red_set (info_flags info) fDELTA
+          *)
+        then 
+	  subs_cons (cbv_stack_term info TOP env b,env)
+	else
+	  subs_lift env in
+      if zeta then
+        norm_head info env' c stack
+      else
+	let normt =
+	  mkLetIn (x, cbv_norm_term info env b,
+		   cbv_norm_term info env t,
+		   cbv_norm_term info env' c) in
+	(VAL(0,normt), stack) (* Considérer une coupure commutative ? *)
+
+  (* non-neutral cases *)
+  | Lambda (x,a,b) -> (LAM(x,a,b,env), stack)
+  | Fix fix -> (FIXP(fix,env,[]), stack)
+  | CoFix cofix -> (COFIXP(cofix,env,[]), stack)
+  | Construct c -> (CONSTR(c, []), stack)
+
+  (* neutral cases *)
+  | (Sort _ | Meta _ | Ind _|Evar _) -> (VAL(0, t), stack)
+  | Prod (x,t,c) -> 
+      (VAL(0, mkProd (x, cbv_norm_term info env t,
+		      cbv_norm_term info (subs_lift env) c)),
+	     stack)
+
+and norm_head_ref k info env stack normt =
+  if red_set_ref (info_flags info) normt then
+    match ref_value_cache info normt with
+      | Some body -> strip_appl (shift_value k body) stack
+      | None -> (VAL(0,make_constr_ref k normt), stack)
+  else (VAL(0,make_constr_ref k normt), stack)
+
+(* cbv_stack_term performs weak reduction on constr t under the subs
+ * env, with context stack, i.e. ([env]t stack).  First computes weak
+ * head normal form of t and checks if a redex appears with the stack.
+ * If so, recursive call to reach the real head normal form.  If not,
+ * we build a value. 
+ *)
+and cbv_stack_term info stack env t =
+  match norm_head info env t stack with
+    (* a lambda meets an application -> BETA *)
+    | (LAM (x,a,b,env), APP (arg::args, stk))
+      when red_set (info_flags info) fBETA ->
+        let subs = subs_cons (arg,env) in
+          cbv_stack_term info (stack_app args stk) subs b
+
+    (* a Fix applied enough -> IOTA *)
+    | (FIXP(fix,env,_), stk)
+        when fixp_reducible (info_flags info) fix stk ->
+        let (envf,redfix) = contract_fixp env fix in
+        cbv_stack_term info stk envf redfix
+
+    (* constructor guard satisfied or Cofix in a Case -> IOTA *)
+    | (COFIXP(cofix,env,_), stk)
+        when cofixp_reducible (info_flags info) cofix stk->
+        let (envf,redfix) = contract_cofixp env cofix in
+        cbv_stack_term info stk envf redfix
+
+    (* constructor in a Case -> IOTA *)
+    | (CONSTR((sp,n),_), APP(args,CASE(_,br,ci,env,stk)))
+            when red_set (info_flags info) fIOTA ->
+	let real_args = list_skipn ci.ci_npar args in
+        cbv_stack_term info (stack_app real_args stk) env br.(n-1)
+         
+    (* constructor of arity 0 in a Case -> IOTA *)
+    | (CONSTR((_,n),_), CASE(_,br,_,env,stk))
+            when red_set (info_flags info) fIOTA ->
+                    cbv_stack_term info stk env br.(n-1)
+
+    (* may be reduced later by application *)  
+    | (head, TOP) -> head
+    | (FIXP(fix,env,_), APP(appl,TOP)) -> FIXP(fix,env,appl) 
+    | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) 
+    | (CONSTR(c,_), APP(appl,TOP)) -> CONSTR(c,appl)
+
+    (* definitely a value *)
+    | (head,stk) -> VAL(0,apply_stack info (cbv_norm_value info head) stk)
+
+
+(* When we are sure t will never produce a redex with its stack, we
+ * normalize (even under binders) the applied terms and we build the
+ * final term
+ *)
+and apply_stack info t = function
+  | TOP -> t
+  | APP (args,st) ->
+      apply_stack info (applistc t (List.map (cbv_norm_value info) args)) st
+  | CASE (ty,br,ci,env,st) ->
+      apply_stack info
+        (mkCase (ci, cbv_norm_term info env ty, t,
+		    Array.map (cbv_norm_term info env) br))
+        st
+
+
+(* performs the reduction on a constr, and returns a constr *)
+and cbv_norm_term info env t =
+  (* reduction under binders *)
+  cbv_norm_value info (cbv_stack_term info TOP env t)
+
+(* reduction of a cbv_value to a constr *)
+and cbv_norm_value info = function (* reduction under binders *)
+  | VAL (n,v) -> lift n v
+  | LAM (x,a,b,env) ->
+      mkLambda (x, cbv_norm_term info env a,
+		cbv_norm_term info (subs_lift env) b)
+  | FIXP ((lij,(names,lty,bds)),env,args) ->
+      applistc
+        (mkFix (lij,
+		(names,
+                 Array.map (cbv_norm_term info env) lty,
+		 Array.map (cbv_norm_term info 
+			      (subs_liftn (Array.length lty) env)) bds)))
+        (List.map (cbv_norm_value info) args)
+  | COFIXP ((j,(names,lty,bds)),env,args) ->
+      applistc
+        (mkCoFix (j,
+		  (names,Array.map (cbv_norm_term info env) lty,
+		   Array.map (cbv_norm_term info 
+				(subs_liftn (Array.length lty) env)) bds)))
+        (List.map (cbv_norm_value info) args)
+  | CONSTR (c,args) ->
+      applistc
+        (mkConstruct c)
+        (List.map (cbv_norm_value info) args)
+
+(* with profiling *)
+let cbv_norm infos constr =
+  with_stats (lazy (cbv_norm_term infos (ESID 0) constr))
+
+
+type cbv_infos = cbv_value infos
+
+(* constant bodies are normalized at the first expansion *)
+let create_cbv_infos flgs env =
+  create
+    (fun old_info c -> cbv_stack_term old_info TOP (ESID 0) c)
+    flgs
+    env
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
new file mode 100644
index 00000000..bf8e03b3
--- /dev/null
+++ b/pretyping/cbv.mli
@@ -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: cbv.mli,v 1.6.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Closure
+open Esubst
+(*i*)
+
+(************************************************************************)
+(*s Call-by-value reduction *)
+
+(* Entry point for cbv normalization of a constr *)
+type cbv_infos
+
+val create_cbv_infos : RedFlags.reds -> env -> cbv_infos
+val cbv_norm         : cbv_infos -> constr -> constr
+
+(************************************************************************)
+(*i This is for cbv debug *)
+type cbv_value =
+  | VAL of int * constr
+  | LAM of name * constr * constr * cbv_value subs
+  | FIXP of fixpoint * cbv_value subs * cbv_value list
+  | COFIXP of cofixpoint * cbv_value subs * cbv_value list
+  | CONSTR of constructor * cbv_value list
+
+val shift_value : int -> cbv_value -> cbv_value
+
+type cbv_stack =
+  | TOP
+  | APP of cbv_value list * cbv_stack
+  | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
+
+val stack_app : cbv_value list -> cbv_stack -> cbv_stack
+val strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack
+
+(* recursive functions... *)
+val cbv_stack_term : cbv_infos ->
+  cbv_stack -> cbv_value subs -> constr -> cbv_value
+val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr
+val norm_head : cbv_infos ->
+  cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack
+val apply_stack : cbv_infos -> constr -> cbv_stack -> constr
+val cbv_norm_value : cbv_infos -> cbv_value -> constr
+(* End of cbv debug section i*)
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
new file mode 100755
index 00000000..2d8fb951
--- /dev/null
+++ b/pretyping/classops.ml
@@ -0,0 +1,397 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: classops.ml,v 1.48.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Options
+open Names
+open Libnames
+open Nametab
+open Environ
+open Libobject
+open Library
+open Term
+open Termops
+open Rawterm
+open Decl_kinds
+
+(* usage qque peu general: utilise aussi dans record *)
+
+(* A class is a type constructor, its type is an arity whose number of
+   arguments is cl_param (0 for CL_SORT and CL_FUN) *)
+
+type cl_typ = 
+  | CL_SORT 
+  | CL_FUN
+  | CL_SECVAR of variable
+  | CL_CONST of constant
+  | CL_IND of inductive
+
+type cl_info_typ = {
+  cl_strength : strength;
+  cl_param : int
+}
+
+type coe_typ = global_reference
+
+type coe_info_typ = {
+  coe_value : unsafe_judgment;
+  coe_strength : strength;
+  coe_is_identity : bool;
+  coe_param : int }
+
+type cl_index = int
+
+type coe_index = coe_info_typ
+
+type inheritance_path = coe_index list
+
+(* table des classes, des coercions et graphe d'heritage *)
+
+module Bijint = struct
+  type ('a,'b) t = { v : ('a * 'b) array; s : int; inv : ('a,int) Gmap.t }
+  let empty = { v = [||]; s = 0; inv = Gmap.empty }
+  let mem y b = Gmap.mem y b.inv
+  let map x b = if 0 <= x & x < b.s then b.v.(x) else raise Not_found
+  let revmap y b = let n = Gmap.find y b.inv in (n, snd (b.v.(n)))
+  let add x y b =
+    let v =
+      if b.s = Array.length b.v then
+	(let v = Array.make (b.s + 8) (x,y) in Array.blit b.v 0 v 0 b.s; v)
+      else b.v in
+    v.(b.s) <- (x,y); { v = v; s = b.s+1; inv = Gmap.add x b.s b.inv }
+  let replace n x y b =
+    let v = Array.copy b.v in v.(n) <- (x,y); { b with v = v }
+  let dom b = Gmap.dom b.inv
+end
+
+let class_tab =
+  ref (Bijint.empty : (cl_typ, cl_info_typ) Bijint.t)
+
+let coercion_tab =
+  ref (Gmap.empty : (coe_typ, coe_info_typ) Gmap.t)
+
+let inheritance_graph =
+  ref (Gmap.empty : (cl_index * cl_index, inheritance_path) Gmap.t)
+
+let freeze () = (!class_tab, !coercion_tab, !inheritance_graph)
+
+let unfreeze (fcl,fco,fig) = 
+  class_tab:=fcl;
+  coercion_tab:=fco;
+  inheritance_graph:=fig
+
+(* ajout de nouveaux "objets" *)
+
+let add_new_class cl s =
+  try
+    let n,s' = Bijint.revmap cl !class_tab in
+    if s.cl_strength = Global & s'.cl_strength <> Global then
+      class_tab := Bijint.replace n cl s !class_tab
+  with Not_found ->
+    class_tab := Bijint.add cl s !class_tab
+
+let add_new_coercion coe s = 
+  coercion_tab := Gmap.add coe s !coercion_tab
+
+let add_new_path x y =
+  inheritance_graph := Gmap.add x y !inheritance_graph
+
+let init () =
+  class_tab:= Bijint.empty; 
+  add_new_class CL_FUN  { cl_param = 0; cl_strength = Global };
+  add_new_class CL_SORT { cl_param = 0; cl_strength = Global };
+  coercion_tab:= Gmap.empty;
+  inheritance_graph:= Gmap.empty
+
+let _ = init()
+
+(* class_info : cl_typ -> int * cl_info_typ *)
+
+let class_info cl = Bijint.revmap cl !class_tab
+
+let class_exists cl = Bijint.mem cl !class_tab
+
+(* class_info_from_index : int -> cl_typ * cl_info_typ *)
+
+let class_info_from_index i = Bijint.map i !class_tab
+
+(* coercion_info : coe_typ -> coe_info_typ *)
+
+let coercion_info coe = Gmap.find coe !coercion_tab
+
+let coercion_exists coe = Gmap.mem coe !coercion_tab
+
+let coercion_params coe_info = coe_info.coe_param
+
+let lookup_path_between (s,t) =
+  Gmap.find (s,t) !inheritance_graph
+
+let lookup_path_to_fun_from s = 
+  lookup_path_between (s,fst(class_info CL_FUN))
+
+let lookup_path_to_sort_from s = 
+  lookup_path_between (s,fst(class_info CL_SORT))
+
+let lookup_pattern_path_between (s,t) =
+  let l = Gmap.find (s,t) !inheritance_graph in
+  List.map  
+    (fun coe ->
+       let c, _ =
+	 Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty 
+	   coe.coe_value.uj_val
+       in 
+       match kind_of_term c with
+	 | Construct sp -> (sp, coe.coe_param)
+	 | _ -> raise Not_found) l
+
+
+let subst_cl_typ subst ct = match ct with
+    CL_SORT
+  | CL_FUN
+  | CL_SECVAR _ -> ct
+  | CL_CONST kn -> 
+      let kn' = subst_kn subst kn in 
+	if kn' == kn then ct else
+	  CL_CONST kn'
+  | CL_IND (kn,i) ->
+      let kn' = subst_kn subst kn in 
+	if kn' == kn then ct else
+	  CL_IND (kn',i)
+
+let subst_coe_typ = subst_global
+
+let subst_coe_info subst info = 
+  let jud = info.coe_value in
+  let val' = subst_mps subst (j_val jud) in
+  let type' = subst_mps subst (j_type jud) in
+    if val' == j_val jud && type' == j_type jud then info else
+      {info with coe_value = make_judge val' type'}
+
+(* library, summary *)
+
+(*val inClass : (cl_typ * cl_info_typ) -> Libobject.object = <fun>
+ val outClass : Libobject.object -> (cl_typ * cl_info_typ) = <fun> *)
+
+let cache_class (_,(x,y)) = add_new_class x y
+
+let subst_class (_,subst,(ct,ci as obj)) = 
+  let ct' = subst_cl_typ subst ct in
+    if ct' == ct then obj else
+      (ct',ci)
+
+let (inClass,outClass) =
+  declare_object {(default_object "CLASS") with 
+		    load_function = (fun _ o -> cache_class o);
+                    cache_function = cache_class;
+		    subst_function = subst_class;
+		    classify_function = (fun (_,x) -> Substitute x); 
+		    export_function = (function x -> Some x)  }
+
+let declare_class (cl,stre,p) = 
+  Lib.add_anonymous_leaf (inClass ((cl,{ cl_strength = stre; cl_param = p })))
+   
+let _ = 
+  Summary.declare_summary "inh_graph"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* classe d'un terme *)
+
+(* find_class_type : constr -> cl_typ * int *)
+
+let find_class_type t =
+  let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in
+  match kind_of_term t' with
+    | Var id -> CL_SECVAR id, args
+    | Const sp -> CL_CONST sp, args
+    | Ind ind_sp -> CL_IND ind_sp, args
+    | Prod (_,_,_) -> CL_FUN, []
+    | Sort _ -> CL_SORT, []
+    |  _ -> raise Not_found
+
+(* class_of : Term.constr -> int *)
+
+let class_of env sigma t = 
+  let (t, n1, i, args) = 
+    try
+      let (cl,args) = find_class_type t in
+      let (i, { cl_param = n1 } ) = class_info cl in
+      (t, n1, i, args)
+    with Not_found ->
+      let t = Tacred.hnf_constr env sigma t in
+      let (cl, args) = find_class_type t in 
+      let (i, { cl_param = n1 } ) = class_info cl in
+      (t, n1, i, args)
+  in
+  if List.length args = n1 then t, i else raise Not_found
+
+let inductive_class_of ind = fst (class_info (CL_IND ind))
+
+let class_args_of c = snd (decompose_app c)
+
+let string_of_class = function
+  | CL_FUN -> if !Options.v7 then "FUNCLASS" else "Funclass"
+  | CL_SORT -> if !Options.v7 then "SORTCLASS" else "Sortclass"
+  | CL_CONST sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp))
+  | CL_IND sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp))
+  | CL_SECVAR sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp))
+
+let pr_class x = str (string_of_class x)
+
+(* coercion_value : coe_index -> unsafe_judgment * bool *)
+
+let coercion_value { coe_value = j; coe_is_identity = b } = (j,b)
+
+(* pretty-print functions are now in Pretty *)
+(* rajouter une coercion dans le graphe *)
+
+let path_printer = ref (fun _ -> str "<a class path>"
+                        : (int * int) * inheritance_path -> std_ppcmds)
+
+let install_path_printer f = path_printer := f
+ 
+let print_path x = !path_printer x
+
+let message_ambig l = 
+  (str"Ambiguous paths:" ++ spc () ++
+   prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l)
+
+(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit 
+                         coercion,source,target *)
+
+let different_class_params i j =
+  (snd (class_info_from_index i)).cl_param > 0
+
+let add_coercion_in_graph (ic,source,target) =
+  let old_inheritance_graph = !inheritance_graph in
+  let ambig_paths =
+    (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
+  let try_add_new_path (i,j as ij) p =
+    try 
+      if i=j then begin
+	if different_class_params i j then begin
+	  let _ = lookup_path_between ij in
+          ambig_paths := (ij,p)::!ambig_paths
+	end
+      end else begin
+        let _ = lookup_path_between (i,j) in
+        ambig_paths := (ij,p)::!ambig_paths
+      end;
+      false
+    with Not_found -> begin
+      add_new_path ij p;
+      true
+    end
+  in
+  let try_add_new_path1 ij p = 
+    let _ = try_add_new_path ij p in () 
+  in
+  if try_add_new_path (source,target) [ic] then begin
+    Gmap.iter 
+      (fun (s,t) p ->
+         if s<>t then begin
+	   if t = source then begin
+             try_add_new_path1 (s,target) (p@[ic]);
+             Gmap.iter
+	       (fun (u,v) q ->
+                  if u<>v & (u = target) & (p <> q) then 
+		    try_add_new_path1 (s,v) (p@[ic]@q))
+               old_inheritance_graph
+           end;
+           if s = target then try_add_new_path1 (source,t) (ic::p)
+	 end)
+      old_inheritance_graph 
+  end;
+  if (!ambig_paths <> []) && is_verbose () then 
+    ppnl (message_ambig !ambig_paths)
+
+type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
+
+let cache_coercion (_,(coe,xf,cls,clt)) =
+  let is,_ = class_info cls in
+  let it,_ = class_info clt in
+  add_new_coercion coe xf;
+  add_coercion_in_graph (xf,is,it)
+
+let subst_coercion (_,subst,(coe,xf,cls,clt as obj)) =
+  let coe' = subst_coe_typ subst coe in
+  let xf' = subst_coe_info subst xf in
+  let cls' = subst_cl_typ subst cls in
+  let clt' = subst_cl_typ subst clt in
+    if coe' == coe && xf' == xf && cls' == cls & clt' == clt then obj else
+      (coe',xf',cls',clt')
+      
+    
+(* val inCoercion : coercion -> Libobject.object 
+   val outCoercion : Libobject.object -> coercion *)
+
+let (inCoercion,outCoercion) =
+  declare_object {(default_object "COERCION") with 
+		    load_function = (fun _ o -> cache_coercion o);
+                    cache_function = cache_coercion;
+		    subst_function = subst_coercion;
+		    classify_function = (fun (_,x) -> Substitute x); 
+                    export_function = (function x -> Some x)  }
+
+let declare_coercion coef v stre ~isid ~src:cls ~target:clt ~params:ps =
+  Lib.add_anonymous_leaf
+    (inCoercion
+       (coef,
+	 { coe_value = v;
+	   coe_strength = stre;
+	   coe_is_identity = isid;
+	   coe_param = ps },
+	cls, clt))
+
+let coercion_strength v = v.coe_strength
+let coercion_identity v = v.coe_is_identity
+
+(* For printing purpose *)
+let get_coercion_value v = v.coe_value.uj_val
+
+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
+  if not (coercion_exists ref) then
+    errorlabstrm "try_add_coercion" 
+      (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion");
+  ref
+
+module CoercionPrinting =
+  struct
+    type t = coe_typ
+    let encode = coercion_of_qualid
+    let subst = subst_coe_typ
+    let printer x = pr_global_env Idset.empty x
+    let key = Goptions.SecondaryTable ("Printing","Coercion")
+    let title = "Explicitly printed coercions: "
+    let member_message x b =
+      str "Explicit printing of coercion " ++ printer x ++
+      str (if b then " is set" else " is unset")
+    let synchronous = true
+  end
+
+module PrintingCoercion  = Goptions.MakeRefTable(CoercionPrinting)
+
+let hide_coercion coe =
+  if not (PrintingCoercion.active coe) then
+    let coe_info = coercion_info coe in
+    Some coe_info.coe_param
+  else None
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
new file mode 100644
index 00000000..f846a9e5
--- /dev/null
+++ b/pretyping/classops.mli
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  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: classops.mli,v 1.30.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Evd
+open Environ
+open Nametab
+(*i*)
+
+(*s This is the type of class kinds *)
+type cl_typ = 
+  | CL_SORT 
+  | CL_FUN 
+  | CL_SECVAR of variable
+  | CL_CONST of constant
+  | CL_IND of inductive
+
+val subst_cl_typ : substitution -> cl_typ -> cl_typ
+
+(* This is the type of infos for declared classes *)
+type cl_info_typ = {
+  cl_strength : strength;
+  cl_param : int }
+
+(* This is the type of coercion kinds *)
+type coe_typ = Libnames.global_reference
+
+(* This is the type of infos for declared coercions *)
+type coe_info_typ 
+
+(* [cl_index] is the type of class keys *)
+type cl_index
+
+(* [coe_index] is the type of coercion keys *)
+type coe_index
+
+(* This is the type of paths from a class to another *)
+type inheritance_path = coe_index list
+
+(*s [declare_class] adds a class to the set of declared classes *)
+val declare_class : cl_typ * strength * int -> unit
+
+(*s Access to classes infos *)
+val class_info : cl_typ -> (cl_index * cl_info_typ)
+val class_exists : cl_typ -> bool
+val class_info_from_index : cl_index -> cl_typ * cl_info_typ
+
+(* [find_class_type c] returns the head reference of c and its
+   arguments *)
+val find_class_type : constr -> cl_typ * constr list
+
+(* raises [Not_found] if not convertible to a class *)
+val class_of : env -> evar_map -> constr -> constr * cl_index
+
+(* raises [Not_found] if not mapped to a class *)
+val inductive_class_of : inductive -> cl_index
+
+val class_args_of : constr -> constr list
+
+(*s [declare_coercion] adds a coercion in the graph of coercion paths *)
+val declare_coercion : 
+  coe_typ -> unsafe_judgment -> strength -> isid:bool ->
+      src:cl_typ -> target:cl_typ -> params:int -> unit
+
+(*s Access to coercions infos *)
+val coercion_exists : coe_typ -> bool
+
+val coercion_value : coe_index -> (unsafe_judgment * bool)
+
+(*s Lookup functions for coercion paths *)
+val lookup_path_between : cl_index * cl_index -> inheritance_path
+val lookup_path_to_fun_from : cl_index -> inheritance_path
+val lookup_path_to_sort_from : cl_index -> inheritance_path
+val lookup_pattern_path_between :
+  cl_index * cl_index -> (constructor * int) list
+
+(*i Pour le discharge *)
+type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
+
+open Libobject
+val inClass : (cl_typ * cl_info_typ) -> Libobject.obj
+val outClass : Libobject.obj -> (cl_typ * cl_info_typ)
+val inCoercion : coercion -> Libobject.obj
+val outCoercion : Libobject.obj -> coercion
+val coercion_strength : coe_info_typ -> strength
+val coercion_identity : coe_info_typ -> bool
+val coercion_params : coe_info_typ -> int
+(*i*)
+
+(*i Crade *)
+open Pp
+val install_path_printer : 
+  ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit
+(*i*)
+
+(*s This is for printing purpose *)
+val string_of_class : cl_typ -> string
+val pr_class : cl_typ -> 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
+val coercions : unit -> coe_index list
+
+(* [hide_coercion] returns the number of params to skip if the coercion must
+   be hidden, [None] otherwise; it raises [Not_found] if not a coercion *)
+val hide_coercion : coe_typ -> int option
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
new file mode 100644
index 00000000..f214388f
--- /dev/null
+++ b/pretyping/coercion.ml
@@ -0,0 +1,211 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(* $Id: coercion.ml,v 1.38.6.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Reductionops
+open Environ
+open Typeops
+open Pretype_errors
+open Classops
+open Recordops
+open Evarutil
+open Evarconv
+open Retyping
+
+(* Typing operations dealing with coercions *)
+
+let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
+
+(* Here, funj is a coercion therefore already typed in global context *)
+let apply_coercion_args env argl funj =
+  let rec apply_rec acc typ = function
+    | [] -> { uj_val = applist (j_val funj,argl);
+              uj_type = typ }
+    | h::restl ->
+    (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+  	match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
+	  | Prod (_,c1,c2) -> 
+              (* Typage garanti par l'appel à app_coercion*)
+	      apply_rec (h::acc) (subst1 h c2) restl
+	  | _ -> anomaly "apply_coercion_args"
+  in 
+  apply_rec [] funj.uj_type argl
+
+exception NoCoercion
+
+(* appliquer le chemin de coercions de patterns p *)
+
+let apply_pattern_coercion loc pat p =
+  List.fold_left
+    (fun pat (co,n) ->
+       let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
+       Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+    pat p
+
+(* raise Not_found if no coercion found *)
+let inh_pattern_coerce_to loc pat ind1 ind2 =
+  let i1 = inductive_class_of ind1 in
+  let i2 = inductive_class_of ind2 in
+  let p = lookup_pattern_path_between (i1,i2) in
+  apply_pattern_coercion loc pat p
+
+(* appliquer le chemin de coercions p à hj *)
+
+let apply_coercion env p hj typ_cl =
+  if !compter then begin
+    nbpathc := !nbpathc +1; 
+    nbcoer := !nbcoer + (List.length p)
+  end;
+  try 
+    fst (List.fold_left
+           (fun (ja,typ_cl) i -> 
+              let fv,isid = coercion_value i in
+              let argl = (class_args_of typ_cl)@[ja.uj_val] in
+              let jres = apply_coercion_args env argl fv in
+              (if isid then 
+		 { uj_val = ja.uj_val; uj_type = jres.uj_type }
+               else 
+		 jres),
+	      jres.uj_type)
+           (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
+  match kind_of_term t with
+    | Prod (_,_,_) -> j
+    | Evar ev when not (is_defined_evar isevars ev) ->
+	let t = define_evar_as_arrow isevars ev in
+	{ uj_val = j.uj_val; uj_type = t }
+    | _ ->
+       	(try
+ 	   let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+      	   let p = lookup_path_to_fun_from i1 in
+           apply_coercion env p j t
+	 with Not_found -> j)
+
+let inh_tosort_force env isevars j =
+  try
+    let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+    let p = lookup_path_to_sort_from i1 in
+    apply_coercion env p j t 
+  with Not_found -> 
+    j
+
+let inh_coerce_to_sort env isevars j =
+  let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+  match kind_of_term typ with
+    | Sort s -> { utj_val = j.uj_val; utj_type = s }
+    | Evar ev when not (is_defined_evar isevars ev) ->
+	let s = define_evar_as_sort isevars ev in
+	{ utj_val = j.uj_val; utj_type = s }
+    | _ ->
+        let j1 = inh_tosort_force env isevars j in 
+	type_judgment env (j_nf_evar (evars_of isevars) j1) 
+
+let inh_coerce_to_fail env isevars c1 hj =
+  let hj' =
+    try 
+      let t1,i1 = class_of1 env (evars_of isevars) c1 in
+      let t2,i2 = class_of1 env (evars_of isevars) hj.uj_type in
+      let p = lookup_path_between (i2,i1) in
+      apply_coercion env p hj t2
+    with Not_found -> raise NoCoercion 
+  in
+  if the_conv_x_leq env isevars hj'.uj_type c1 then 
+    hj'
+  else
+    raise NoCoercion
+
+let rec inh_conv_coerce_to_fail env isevars hj c1 =
+  let {uj_val = v; uj_type = t} = hj in
+  if the_conv_x_leq env isevars t c1 then hj
+  else 
+    try 
+      inh_coerce_to_fail env isevars c1 hj
+    with NoCoercion ->  (* try ... with _ -> ... is BAD *)
+      (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
+	     kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
+	 | Prod (_,t1,t2), Prod (name,u1,u2) -> 
+             let v' = whd_betadeltaiota env (evars_of isevars) v in
+             if (match kind_of_term v' with
+                   | Lambda (_,v1,v2) ->
+                       the_conv_x env isevars v1 u1 (* leq v1 u1? *)
+                   | _  -> false)
+             then 
+	       let (x,v1,v2) = destLambda v' in
+               let env1 = push_rel (x,None,v1) env in
+               let h2 = inh_conv_coerce_to_fail env1 isevars 
+			  {uj_val = v2; uj_type = t2 } u2 in
+               { uj_val = mkLambda (x, v1, h2.uj_val);
+                 uj_type = mkProd (x, v1, h2.uj_type) }
+             else 
+               (* 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 h1 =
+		 inh_conv_coerce_to_fail env1 isevars
+		   {uj_val = mkRel 1; uj_type = (lift 1 u1) }
+                   (lift 1 t1) in
+               let h2 = inh_conv_coerce_to_fail env1 isevars
+			 { uj_val = mkApp (lift 1 v, [|h1.uj_val|]);
+                           uj_type = subst1 h1.uj_val t2 }
+                          u2
+	       in
+               { uj_val = mkLambda (name, u1, h2.uj_val);
+                 uj_type = mkProd (name, u1, h2.uj_type) }
+	 | _ -> 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 t =
+  let cj' = 
+    try 
+      inh_conv_coerce_to_fail env isevars cj t
+    with NoCoercion ->
+      let sigma = evars_of isevars in
+      error_actual_type_loc loc env sigma cj t
+  in
+  { uj_val = cj'.uj_val; uj_type = t }
+
+(* [inh_apply_rel_list loc env isevars args f tycon] tries to type [(f
+   args)] of type [tycon] (if any) by inserting coercions in front of
+   each arg$_i$, if necessary *)
+
+let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon =
+  let rec apply_rec env n resj = function
+    | [] -> resj
+    | (loc,hj)::restjl ->
+        let sigma = evars_of isevars in
+	let resj = inh_app_fun env isevars resj in
+        let ntyp = whd_betadeltaiota env sigma resj.uj_type in
+      	match kind_of_term ntyp with
+          | Prod (na,c1,c2) ->
+              let hj' =
+		try 
+		  inh_conv_coerce_to_fail env isevars hj c1
+		with NoCoercion ->
+                  error_cant_apply_bad_type_loc apploc env sigma
+		    (1,c1,hj.uj_type) resj (List.map snd restjl) in
+	      let newresj =
+      		{ uj_val = applist (j_val resj, [j_val hj']);
+		  uj_type = subst1 hj'.uj_val c2 } in
+	      apply_rec (push_rel (na,None,c1) env) (n+1) newresj restjl
+          | _ ->
+              error_cant_apply_not_functional_loc 
+		(join_loc funloc loc) env sigma resj
+                (List.map snd restjl)
+  in 
+  apply_rec env 1 funj argjl
+
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
new file mode 100644
index 00000000..658844eb
--- /dev/null
+++ b/pretyping/coercion.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  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: coercion.mli,v 1.20.14.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Evd
+open Names
+open Term
+open Sign
+open Environ
+open Evarutil
+open Rawterm
+(*i*)
+
+(*s Coercions. *)
+
+(* [inh_app_fun env isevars 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 -> unsafe_judgment
+
+(* [inh_coerce_to_sort env isevars 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 :
+  env -> evar_defs -> unsafe_judgment -> unsafe_type_judgment
+
+(* [inh_conv_coerce_to loc env isevars 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 -> constr -> unsafe_judgment
+
+(* [inh_pattern_coerce_to loc env isevars 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 :
+  loc  -> cases_pattern -> inductive -> inductive -> cases_pattern
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
new file mode 100644
index 00000000..41f63ace
--- /dev/null
+++ b/pretyping/detyping.ml
@@ -0,0 +1,492 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: detyping.ml,v 1.75.2.4 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Pp
+open Util
+open Univ
+open Names
+open Term
+open Declarations
+open Inductive
+open Inductiveops
+open Environ
+open Sign
+open Rawterm
+open Nameops
+open Termops
+open Libnames
+open Nametab
+
+(****************************************************************************)
+(* Tools for printing of Cases                                              *)
+
+let encode_inductive qid =
+  let indsp = global_inductive qid in
+  let constr_lengths = mis_constr_nargs indsp in
+  (indsp,constr_lengths)
+
+(* Parameterization of the translation from constr to ast      *)
+
+(* Tables for Cases printing under a "if" form, a "let" form,  *)
+
+let has_two_constructors lc =
+  Array.length lc = 2 (* & lc.(0) = 0 & lc.(1) = 0 *)
+
+let isomorphic_to_tuple lc = (Array.length lc = 1)
+
+let encode_bool r =
+  let (_,lc as x) = encode_inductive r in
+  if not (has_two_constructors lc) then
+    user_err_loc (loc_of_reference r,"encode_if",
+      str "This type has not exactly two constructors");
+  x
+
+let encode_tuple r =
+  let (_,lc as x) = encode_inductive r in
+  if not (isomorphic_to_tuple lc) then
+    user_err_loc (loc_of_reference r,"encode_tuple",
+      str "This type cannot be seen as a tuple type");
+  x
+
+module PrintingCasesMake =
+  functor (Test : sig 
+     val encode : reference -> inductive * int array
+     val member_message : std_ppcmds -> bool -> std_ppcmds
+     val field : string
+     val title : string
+  end) ->
+  struct
+    type t = inductive * int array
+    let encode = Test.encode
+    let subst subst ((kn,i), ints as obj) =
+      let kn' = subst_kn subst kn in
+	if kn' == kn then obj else
+	  (kn',i), ints
+    let printer (ind,_) = pr_global_env Idset.empty (IndRef ind)
+    let key = Goptions.SecondaryTable ("Printing",Test.field)
+    let title = Test.title
+    let member_message x = Test.member_message (printer x)
+    let synchronous = true
+  end
+
+module PrintingCasesIf =
+  PrintingCasesMake (struct 
+    let encode = encode_bool
+    let field = "If"
+    let title = "Types leading to pretty-printing of Cases using a `if' form: "
+    let member_message s b =
+      str "Cases on elements of " ++ s ++ 
+      str
+	(if b then " are printed using a `if' form"
+         else " are not printed using a `if' form")
+  end)
+
+module PrintingCasesLet =
+  PrintingCasesMake (struct 
+    let encode = encode_tuple
+    let field = "Let"
+    let title = 
+      "Types leading to a pretty-printing of Cases using a `let' form:"
+    let member_message s b =
+      str "Cases on elements of " ++ s ++
+      str
+	(if b then " are printed using a `let' form"
+         else " are not printed using a `let' form")
+  end)
+
+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 *)
+
+open Goptions
+
+let wildcard_value = ref true
+let force_wildcard () = !wildcard_value
+
+let _ = declare_bool_option 
+	  { optsync  = true;
+	    optname  = "forced wildcard";
+	    optkey   = SecondaryTable ("Printing","Wildcard");
+	    optread  = force_wildcard;
+	    optwrite = (:=) wildcard_value }
+
+let synth_type_value = ref true
+let synthetize_type () = !synth_type_value
+
+let _ = declare_bool_option 
+	  { optsync  = true;
+	    optname  = "synthesizability";
+	    optkey   = SecondaryTable ("Printing","Synth");
+	    optread  = synthetize_type;
+	    optwrite = (:=) synth_type_value }
+
+(* Auxiliary function for MutCase printing *)
+(* [computable] tries to tell if the predicate typing the result is inferable*)
+
+let computable p k =
+    (* We first remove as many lambda as the arity, then we look
+       if it remains a lambda for a dependent elimination. This function
+       works for normal eta-expanded term. For non eta-expanded or
+       non-normal terms, it may affirm the pred is synthetisable
+       because of an undetected ultimate dependent variable in the second
+       clause, or else, it may affirms the pred non synthetisable
+       because of a non normal term in the fourth clause.
+       A solution could be to store, in the MutCase, the eta-expanded
+       normal form of pred to decide if it depends on its variables
+
+       Lorsque le prédicat est dépendant de manière certaine, on
+       ne déclare pas le prédicat synthétisable (même si la
+       variable dépendante ne l'est pas effectivement) parce que
+       sinon on perd la réciprocité de la synthèse (qui, lui,
+       engendrera un prédicat non dépendant) *)
+
+  (nb_lam p = k+1)
+  &&
+  let _,ccl = decompose_lam p in 
+  noccur_between 1 (k+1) ccl
+
+
+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
+           | (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
+           | (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'))
+    | Cast (c,_) -> lookup avoid env_names n c
+    | _ -> None
+  in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t
+
+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
+               (Name _,_) -> lookup n (d+1) c'
+             | (Anonymous,_) -> 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
+             | (Name _,_) -> lookup n (d+1) c'
+             | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c')
+    | Cast (c,_) -> lookup n d c
+    | _ -> None
+  in lookup n 1 t
+
+let is_nondep_branch c n =
+  try
+    let _,ccl = decompose_lam_n_assum n c in
+    noccur_between 1 n 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
+      | RLetIn (_,_,_,t) -> strip (n-1) t
+      | _ -> assert false in
+  if test c n then Some (strip n b) else None
+
+let detype_case computable detype detype_eqn testdep
+    tenv avoid indsp st p k c bl =
+  let synth_type = synthetize_type () in
+  let tomatch = detype c in
+
+  (* Find constructors arity *)
+  let (mib,mip) = Inductive.lookup_mind_specif tenv indsp in
+  let get_consnarg j = 
+    let typi = mis_nf_constructor_type (indsp,mib,mip) (j+1) in
+    let _,t = decompose_prod_n_assum (List.length mip.mind_params_ctxt) typi in
+    List.rev (fst (decompose_prod_assum t)) in
+  let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
+  let consnargsl = Array.map List.length consnargs in
+  let alias, aliastyp, newpred, pred = 
+    if (not !Options.raw_print) & synth_type & computable & bl <> [||] then
+      Anonymous, None, None, None
+    else
+      let p = option_app detype p in
+      match p with
+        | None -> Anonymous, None, None, None
+        | Some p ->
+            let decompose_lam k c =
+              let rec lamdec_rec l avoid k c =
+                if k = 0 then List.rev l,c else match c with
+                  | RLambda (_,x,t,c) -> 
+                      lamdec_rec (x::l) (name_cons x avoid) (k-1) c
+                  | c -> 
+                      let x = next_ident_away (id_of_string "x") avoid in
+                      lamdec_rec ((Name x)::l) (x::avoid) (k-1)
+                        (let a = RVar (dummy_loc,x) in
+                          match c with
+                          | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+                          | _ -> (RApp (dummy_loc,c,[a])))
+              in 
+              lamdec_rec [] [] k c in
+            let nl,typ = decompose_lam k p in
+	    let n,typ = match typ with 
+              | RLambda (_,x,t,c) -> x, c
+	      | _ -> Anonymous, typ in
+	    let aliastyp =
+	      if List.for_all ((=) Anonymous) nl then None
+	      else 
+		let pars = list_tabulate (fun _ -> Anonymous) mip.mind_nparams
+		in Some (dummy_loc,indsp,pars@nl) in
+            n, aliastyp, Some typ, Some p
+  in
+  let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
+  let eqnv = array_map3 detype_eqn constructs consnargsl bl in
+  let eqnl = Array.to_list eqnv in
+  let tag =
+    try 
+      if !Options.raw_print then
+        RegularStyle
+      else if PrintingLet.active (indsp,consnargsl) then
+	LetStyle
+      else if PrintingIf.active (indsp,consnargsl) then 
+	IfStyle
+      else 
+	st
+    with Not_found -> st
+  in 
+  if tag = RegularStyle then
+    RCases (dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
+  else
+    let bl' = Array.map detype bl in
+    if not !Options.v7 && tag = LetStyle && aliastyp = None then
+      let rec decomp_lam_force n avoid l p =
+	if n = 0 then (List.rev l,p) else
+          match p with
+            | RLambda (_,na,_,c) -> 
+		decomp_lam_force (n-1) (name_cons na avoid) (na::l) c
+            | RLetIn (_,na,_,c) -> 
+		decomp_lam_force (n-1) (name_cons na avoid) (na::l) c
+            | _ ->
+		let x = Nameops.next_ident_away (id_of_string "x") avoid in
+		decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+                  (* eta-expansion *)
+                  (let a = RVar (dummy_loc,x) in
+                  match p with
+                    | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+                    | _ -> (RApp (dummy_loc,p,[a]))) in
+      let (nal,d) = decomp_lam_force consnargsl.(0) avoid [] bl'.(0) in
+      RLetTuple (dummy_loc,nal,(alias,newpred),tomatch,d)
+    else
+    let nondepbrs =
+      array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
+    if not !Options.v7 && tag = IfStyle && aliastyp = None
+      && array_for_all ((<>) None) nondepbrs then
+      RIf (dummy_loc,tomatch,(alias,newpred),
+           out_some nondepbrs.(0),out_some nondepbrs.(1))
+    else if !Options.v7 then
+      let rec remove_type avoid args c =
+	match c,args with
+          | RLambda (loc,na,t,c), _::args ->
+              let h = RHole (dummy_loc,BinderType na) in
+              RLambda (loc,na,h,remove_type avoid args c)
+          | RLetIn (loc,na,b,c), _::args ->
+              RLetIn (loc,na,b,remove_type avoid args c)
+          | c, (na,None,t)::args ->
+              let id = next_name_away_with_default "x" na avoid in
+              let h = RHole (dummy_loc,BinderType na) in
+              let c = remove_type (id::avoid) args
+		(RApp (dummy_loc,c,[RVar (dummy_loc,id)])) in
+              RLambda (dummy_loc,Name id,h,c)
+          | c, (na,Some b,t)::args ->
+              let h = RHole (dummy_loc,BinderType na) in
+              let avoid = name_fold (fun x l -> x::l) na avoid in
+              RLetIn (dummy_loc,na,h,remove_type avoid args c)
+          | c, [] -> c in
+      let bl' = array_map2 (remove_type avoid) consnargs bl' in
+      ROrderedCase (dummy_loc,tag,pred,tomatch,bl',ref None)
+    else
+      RCases(dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
+
+
+let rec detype tenv avoid env t =
+  match kind_of_term (collapse_appl t) with
+    | Rel n ->
+      (try match lookup_name_of_rel n env with
+	 | Name id   -> RVar (dummy_loc, id)
+	 | Anonymous -> anomaly "detype: index to an anonymous variable"
+       with Not_found ->
+	 let s = "_UNBOUND_REL_"^(string_of_int n)
+	 in RVar (dummy_loc, id_of_string s))
+    | Meta n ->
+	(* Meta in constr are not user-parsable and are mapped to Evar *)
+	REvar (dummy_loc, n, None)
+    | Var id ->
+	(try
+	  let _ = Global.lookup_named id in RRef (dummy_loc, VarRef id)
+	 with _ ->
+	  RVar (dummy_loc, id))
+    | Sort (Prop c) -> RSort (dummy_loc,RProp c)
+    | Sort (Type u) -> RSort (dummy_loc,RType (Some u))
+    | Cast (c1,c2) ->
+	RCast(dummy_loc,detype tenv avoid env c1,
+              detype tenv avoid env c2)
+    | Prod (na,ty,c) -> detype_binder tenv BProd avoid env na ty c
+    | Lambda (na,ty,c) -> detype_binder tenv BLambda avoid env na ty c
+    | LetIn (na,b,_,c) -> detype_binder tenv BLetIn avoid env na b c
+    | App (f,args) ->
+	RApp (dummy_loc,detype tenv avoid env f,
+              array_map_to_list (detype tenv avoid env) args)
+    | Const sp -> RRef (dummy_loc, ConstRef sp)
+    | Evar (ev,cl) ->
+        REvar (dummy_loc, ev, 
+               Some (List.map (detype tenv avoid env) (Array.to_list cl)))
+    | Ind ind_sp ->
+	RRef (dummy_loc, IndRef ind_sp)
+    | Construct cstr_sp ->
+	RRef (dummy_loc, ConstructRef cstr_sp)
+    | Case (annot,p,c,bl) ->
+	let comp = computable p (annot.ci_pp_info.ind_nargs) in
+	let ind = annot.ci_ind in
+	let st = annot.ci_pp_info.style in
+	detype_case comp (detype tenv avoid env) (detype_eqn tenv avoid env)
+	  is_nondep_branch
+	  (snd tenv) avoid ind st (Some p) annot.ci_pp_info.ind_nargs c bl
+    | Fix (nvn,recdef) -> detype_fix tenv avoid env nvn recdef
+    | CoFix (n,recdef) -> detype_cofix tenv avoid env n recdef
+
+and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) =
+  let def_avoid, def_env, lfi =
+    Array.fold_left
+      (fun (avoid, env, l) na ->
+	 let id = next_name_away na avoid in 
+	 (id::avoid, add_name (Name id) env, id::l))
+      (avoid, env, []) names in
+  let n = Array.length tys in
+  let v = array_map3
+    (fun c t i -> share_names tenv (i+1) [] def_avoid def_env c (lift n t))
+    bodies tys vn in
+  RRec(dummy_loc,RFix nvn,Array.of_list (List.rev lfi),
+       Array.map (fun (bl,_,_) -> bl) v,
+       Array.map (fun (_,_,ty) -> ty) v,
+       Array.map (fun (_,bd,_) -> bd) v)
+
+and detype_cofix tenv avoid env n (names,tys,bodies) =
+  let def_avoid, def_env, lfi =
+    Array.fold_left
+      (fun (avoid, env, l) na ->
+	 let id = next_name_away na avoid in 
+	 (id::avoid, add_name (Name id) env, id::l))
+      (avoid, env, []) names in
+  let ntys = Array.length tys in
+  let v = array_map2
+    (fun c t -> share_names tenv 0 [] def_avoid def_env c (lift ntys t))
+    bodies tys in
+  RRec(dummy_loc,RCoFix n,Array.of_list (List.rev lfi),
+       Array.map (fun (bl,_,_) -> bl) v,
+       Array.map (fun (_,_,ty) -> ty) v,
+       Array.map (fun (_,bd,_) -> bd) v)
+
+and share_names tenv n l avoid env c t =
+  if !Options.v7 && n=0 then
+    let c = detype tenv avoid env c in
+    let t = detype tenv avoid env t in
+    (List.rev l,c,t)
+  else
+  match kind_of_term c, kind_of_term t with
+    (* factorize even when not necessary to have better presentation *)
+    | Lambda (na,t,c), Prod (na',t',c') ->
+        let na = match (na,na') with
+            Name _, _ -> na
+          | _, Name _ -> na'
+          | _ -> na in 
+        let t = detype tenv 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 tenv (n-1) ((Name id,None,t)::l) avoid env c c'
+    (* May occur for fix built interactively *)
+    | LetIn (na,b,t',c), _ when n > 0 ->
+        let t' = detype tenv avoid env t' in
+        let b = detype tenv 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 tenv n ((Name id,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 tenv n l avoid env c (subst1 b t)
+    (* If it is an open proof: we cheat and eta-expand *)
+    | _, Prod (na',t',c') when n > 0 ->
+        let t' = detype tenv avoid env t' in
+	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 tenv (n-1) ((Name id,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";
+        let c = detype tenv avoid env c in
+        let t = detype tenv avoid env t in
+        (List.rev l,c,t)
+
+and detype_eqn tenv avoid env constr construct_nargs branch =
+  let make_pat x avoid env b ids =
+    if force_wildcard () & noccurn 1 b then
+      PatVar (dummy_loc,Anonymous),avoid,(add_name Anonymous env),ids
+    else 
+      let id = next_name_away_with_default "x" x avoid in
+      PatVar (dummy_loc,Name id),id::avoid,(add_name (Name id) env),id::ids
+  in
+  let rec buildrec ids patlist avoid env n b =
+    if n=0 then
+      (dummy_loc, ids, 
+       [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
+       detype tenv avoid env b)
+    else
+      match kind_of_term b with
+	| Lambda (x,_,b) -> 
+	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
+            buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
+
+	| LetIn (x,_,_,b) -> 
+	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
+            buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
+
+	| Cast (c,_) ->    (* Oui, il y a parfois des cast *)
+	    buildrec ids patlist avoid env n c
+
+	| _ -> (* eta-expansion : n'arrivera plus lorsque tous les
+                  termes seront construits à partir de la syntaxe Cases *)
+            (* nommage de la nouvelle variable *)
+	    let new_b = applist (lift 1 b, [mkRel 1]) in
+            let pat,new_avoid,new_env,new_ids =
+	      make_pat Anonymous avoid env new_b ids in
+	    buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b
+	  
+  in 
+  buildrec [] [] avoid env construct_nargs branch
+
+and detype_binder tenv bk avoid env na ty c =
+  let na',avoid' =
+    if bk = BLetIn then
+      concrete_let_name (fst tenv) avoid env na c
+    else
+      concrete_name (fst tenv) avoid env na c in
+  let r =  detype tenv avoid' (add_name na' env) c in
+  match bk with
+    | BProd -> RProd (dummy_loc, na',detype tenv [] env ty, r)
+    | BLambda -> RLambda (dummy_loc, na',detype tenv [] env ty, r)
+    | BLetIn -> RLetIn (dummy_loc, na',detype tenv [] env ty, r)
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
new file mode 100644
index 00000000..c2a70928
--- /dev/null
+++ b/pretyping/detyping.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  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: detyping.mli,v 1.13.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Rawterm
+open Termops
+(*i*)
+
+(* [detype env avoid nenv c] turns [c], typed in [env], into a rawconstr. *)
+(* De Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
+
+val detype : bool * env -> identifier list -> names_context -> constr -> 
+  rawconstr
+
+val detype_case : 
+  bool -> ('a -> rawconstr) ->
+  (constructor -> int -> 'a -> loc * identifier list * cases_pattern list *
+    rawconstr) -> ('a -> int -> bool) ->
+    env -> identifier list -> inductive -> case_style ->
+      'a option -> int -> 'a -> 'a array -> rawconstr
+
+(* 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
+
+
+val force_wildcard : unit -> bool
+val synthetize_type : unit -> bool
+val force_if : case_info -> bool
+val force_let : case_info -> bool
diff --git a/pretyping/doc.tex b/pretyping/doc.tex
new file mode 100644
index 00000000..d92a027e
--- /dev/null
+++ b/pretyping/doc.tex
@@ -0,0 +1,14 @@
+
+\newpage
+\section*{Pre-typing}
+
+\ocwsection \label{pretyping}
+
+\bigskip
+\begin{center}\epsfig{file=pretyping.dep.ps,width=\linewidth}\end{center}
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
new file mode 100644
index 00000000..6f396b43
--- /dev/null
+++ b/pretyping/evarconv.ml
@@ -0,0 +1,397 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: evarconv.ml,v 1.44.6.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Reductionops
+open Closure
+open Instantiate
+open Environ
+open Typing
+open Classops
+open Recordops 
+open Evarutil
+open Libnames
+
+type flex_kind_of_term =
+  | Rigid of constr 
+  | MaybeFlexible of constr
+  | Flexible of existential
+
+let flex_kind_of_term c l =
+  match kind_of_term c with
+    | Const _ -> MaybeFlexible c
+    | Rel n -> MaybeFlexible c
+    | Var id -> MaybeFlexible c
+    | Lambda _ when l<>[] -> MaybeFlexible c
+    | LetIn _  -> MaybeFlexible c
+    | Evar ev -> Flexible ev
+    | _ -> Rigid c
+
+let eval_flexible_term env c =
+  match kind_of_term c with
+  | Const c -> constant_opt_value env c
+  | Rel n -> let (_,v,_) = lookup_rel n env in option_app (lift n) v
+  | Var id -> let (_,v,_) = lookup_named id env in v
+  | 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 (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 rec aux s =
+    let (t,stack as s') = Reductionops.apprec env sigma s in
+    match kind_of_term t with
+      | Evar (n,_ as ev) when Evd.is_defined sigma n ->
+	  aux (existential_value sigma ev, stack)
+      | _ -> (t, list_of_stack stack)
+  in aux (c, append_stack (Array.of_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
+
+(* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem
+   (t1 l1) = (t2 l2) into a problem
+
+     l1 = params1@c1::extra_args1
+     l2 = us2@extra_args2
+     (t1 params1 c1) = (proji params (c xs))
+     (t2 us2) = (cstr us)
+     extra_args1 = extra_args2
+
+   by finding a record R and an object c := [xs:bs](Build_R a1..am v1..vn)
+   with vi = (cstr us), for which we know that the i-th projection proji
+   satisfies
+
+      (proji params c) = (cstr us)
+
+   Rem: such objects, usable for conversion, are defined in the objdef
+   table; practically, it amounts to "canonically" equip t2 into a
+   object c in structure R (since, if c1 were not an evar, the
+   projection would have been reduced) *)
+
+let check_conv_record (t1,l1) (t2,l2) =
+  try
+    let proji = reference_of_constr t1 in
+    let cstr = reference_of_constr t2 in
+    let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = 
+      objdef_info (proji, cstr) 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
+  with _ -> 
+    raise Not_found
+
+
+(* Precondition: one of the terms of the pb is an uninstanciated evar,
+ * possibly applied to arguments. *)
+
+let rec evar_conv_x env isevars pbty term1 term2 = 
+  let sigma = evars_of isevars 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  *)
+  (not (has_undefined_isevars isevars term1) &
+   not (has_undefined_isevars isevars term2) &
+   is_fconv pbty env (evars_of isevars) term1 term2) 
+  or
+  if ise_undefined isevars term1 then
+    solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2)
+  else if ise_undefined 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
+    if (head_is_embedded_evar isevars t1 & not(is_eliminator t2))
+      or (head_is_embedded_evar isevars t2 & not(is_eliminator t1))
+    then 
+      (add_conv_pb isevars (pbty,applist(t1,l1),applist(t2,l2)); true)
+    else 
+      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) =
+  (* 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) ->
+	let f1 () =
+	  if List.length l1 > List.length l2 then 
+            let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+            solve_simple_eqn evar_conv_x env isevars 
+	      (pbty,ev2,applist(term1,deb1))
+            & list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2
+	  else
+	    let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+	    solve_simple_eqn evar_conv_x env isevars
+	      (pbty,ev1,applist(term2,deb2))
+            & list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2
+	and f2 () =
+          (sp1 = sp2)
+	  & (array_for_all2 (evar_conv_x env isevars CONV) al1 al2)  
+	  & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+	in 
+	ise_try isevars [f1; f2]
+
+    | Flexible ev1, MaybeFlexible flex2 ->
+	let f1 () =
+	  (List.length l1 <= List.length l2) &
+	  let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+          (* First compare extra args for better failure message *)
+          list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
+	  evar_conv_x env isevars pbty term1 (applist(term2,deb2))
+	and f4 () =
+	  match eval_flexible_term env flex2 with
+	    | Some v2 ->
+		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars l2 v2)
+	    | None -> false
+	in 
+	ise_try isevars [f1; f4]
+
+    | MaybeFlexible flex1, Flexible ev2 ->
+	let f1 () =
+       	  (List.length l2 <= List.length l1) &
+       	  let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+          (* First compare extra args for better failure message *)
+          list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
+	  evar_conv_x env isevars pbty (applist(term1,deb1)) term2
+	and f4 () =
+	  match eval_flexible_term env flex1 with
+	    | Some v1 ->
+		evar_eqappr_x env isevars pbty
+		  (evar_apprec env isevars l1 v1) appr2
+	    | None -> false
+	in 
+	ise_try isevars [f1; f4]
+
+    | MaybeFlexible flex1, MaybeFlexible flex2 ->
+	let f2 () =
+          (flex1 = flex2)
+	  & (List.length l1 = List.length l2)
+	  & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+	and f3 () =
+	  (try conv_record env isevars 
+             (try check_conv_record appr1 appr2
+	      with Not_found -> check_conv_record appr2 appr1)
+           with _ -> false)
+	and f4 () =
+          (* heuristic: unfold second argument first, exception made
+             if the first argument is a beta-redex (expand a constant
+             only if necessary) *)
+          let val2 =
+            match kind_of_term flex1 with
+                Lambda _ -> None
+              | _ -> eval_flexible_term env flex2 in
+	  match val2 with
+	    | Some v2 ->
+		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars l2 v2)
+	    | None ->
+		match eval_flexible_term env flex1 with
+		  | Some v1 ->
+		      evar_eqappr_x env isevars pbty
+			(evar_apprec env isevars l1 v1) appr2
+		  | None -> false
+	in 
+	ise_try isevars [f2; f3; f4]
+
+    | Flexible ev1, Rigid _ ->
+       	(List.length l1 <= List.length l2) &
+       	let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+        (* First compare extra args for better failure message *)
+        list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
+	solve_simple_eqn evar_conv_x env isevars
+	  (pbty,ev1,applist(term2,deb2))
+
+    | Rigid _, Flexible ev2 ->
+       	(List.length l2 <= List.length l1) &
+       	let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+        (* First compare extra args for better failure message *)
+        list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
+	solve_simple_eqn evar_conv_x env isevars
+	  (pbty,ev2,applist(term1,deb1))
+        
+
+    | MaybeFlexible flex1, Rigid _ ->
+	let f3 () =
+	  (try conv_record env isevars (check_conv_record appr1 appr2)
+           with _ -> false)
+	and f4 () =
+	  match eval_flexible_term env flex1 with
+	    | Some v1 ->
+ 		evar_eqappr_x env isevars pbty
+		  (evar_apprec env isevars l1 v1) appr2
+	    | None -> false
+	in 
+	ise_try isevars [f3; f4]
+	     
+    | Rigid _ , MaybeFlexible flex2 -> 
+	let f3 () = 
+	  (try (conv_record env isevars (check_conv_record appr2 appr1))
+           with _ -> false)
+	and f4 () =
+	  match eval_flexible_term env flex2 with
+	    | Some v2 ->
+ 		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars l2 v2)
+	    | None -> false
+	in 
+	ise_try isevars [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 (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
+
+	| Sort s1, Sort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2
+
+	| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> 
+	    evar_conv_x env isevars CONV c1 c2
+	    & 
+	    (let c = nf_evar (evars_of isevars) c1 in
+             evar_conv_x (push_rel (na,None,c) env) isevars CONV c'1 c'2)
+
+	| LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
+	    let f1 () =
+	      evar_conv_x env isevars CONV b1 b2
+	      & 
+              (let b = nf_evar (evars_of isevars) b1 in
+	       let t = nf_evar (evars_of isevars) t1 in
+               evar_conv_x (push_rel (na,Some b,t) env) isevars pbty c'1 c'2)
+	      & (List.length l1 = List.length l2)
+	      & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2)
+	    and f2 () =
+              let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1)
+              and appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
+	      in evar_eqappr_x env isevars pbty appr1 appr2
+	    in 
+	    ise_try isevars [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
+
+	| _, LetIn (_,b2,_,c'2) ->
+	    let appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
+            in evar_eqappr_x env isevars pbty appr1 appr2
+
+	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> 
+            evar_conv_x env isevars CONV c1 c2
+            & 
+	    (let c = nf_evar (evars_of isevars) c1 in
+	     evar_conv_x (push_rel (n,None,c) env) isevars pbty c'1 c'2)
+
+	| Ind sp1, Ind sp2 ->
+	    sp1=sp2
+            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+             
+	| Construct sp1, Construct sp2 ->
+	    sp1=sp2
+            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+
+	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
+	    evar_conv_x env isevars CONV p1 p2
+	    & evar_conv_x env isevars CONV c1 c2
+	    & (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2)
+	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+
+	| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
+	    li1=li2
+	    & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
+	    & (array_for_all2
+		 (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
+		 bds1 bds2)
+	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+	     
+	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
+	    i1=i2 
+	    & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
+	    & (array_for_all2
+		 (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
+		 bds1 bds2)
+	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+
+	| (Meta _ | Lambda _), _ -> false
+	| _, (Meta _ | Lambda _) -> false
+
+	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> false
+	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> false
+
+	| (App _ | Case _ | Fix _ | CoFix _), 
+	  (App _ | Case _ | Fix _ | CoFix _) -> 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 ks =
+    List.fold_left
+      (fun ks b ->
+	 let dloc = (dummy_loc,Rawterm.InternalHole) in
+	 (new_isevar isevars env dloc (substl ks b)) :: ks)
+      [] bs
+  in
+  if (list_for_all2eq 
+	(fun u1 u -> evar_conv_x env isevars CONV u1 (substl ks u))
+	us2 us)
+    &
+    (list_for_all2eq 
+       (fun x1 x -> evar_conv_x env isevars CONV x1 (substl ks x))
+       params1 params)
+    & (list_for_all2eq (evar_conv_x env isevars CONV) ts ts1)
+    & (evar_conv_x env isevars CONV c1 (applist (c,(List.rev ks))))
+  then
+    (*TR*) (if !compter then (nbstruc:=!nbstruc+1;
+                              nbimplstruc:=!nbimplstruc+(List.length ks);true)
+            else true)
+  else false
+
+let the_conv_x     env isevars t1 t2 = evar_conv_x env isevars CONV  t1 t2
+let the_conv_x_leq env isevars t1 t2 = evar_conv_x env isevars CUMUL t1 t2
+ 
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
new file mode 100644
index 00000000..8785d855
--- /dev/null
+++ b/pretyping/evarconv.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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: evarconv.mli,v 1.11.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Sign
+open Environ
+open Reductionops
+open Evarutil
+(*i*)
+
+val the_conv_x : env -> evar_defs -> constr -> constr -> bool
+
+val the_conv_x_leq : env -> evar_defs -> constr -> constr -> bool
+
+(*i For debugging *)
+val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> bool
+val evar_eqappr_x : 
+  env -> evar_defs ->
+    conv_pb -> constr * constr list -> constr * constr list -> bool
+(*i*)
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
new file mode 100644
index 00000000..441070fe
--- /dev/null
+++ b/pretyping/evarutil.ml
@@ -0,0 +1,579 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: evarutil.ml,v 1.64.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Nameops
+open Univ
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Instantiate
+open Reductionops
+open Indrec
+open Pretype_errors
+
+
+let rec filter_unique = function
+  | [] -> []
+  | x::l ->
+      if List.mem x l then filter_unique (List.filter (fun y -> x<>y) l)
+      else x::filter_unique l
+
+(*
+let distinct_id_list = 
+  let rec drec fresh = function
+      [] -> List.rev fresh 
+    | id::rest ->
+ 	let id' = next_ident_away_from id fresh in drec (id'::fresh) rest
+  in drec []
+*)
+
+(*
+let filter_sign p sign x =
+  sign_it
+    (fun id ty (v,ids,sgn) ->
+      let (disc,v') = p v (id,ty) in
+      if disc then (v', id::ids, sgn) else (v', ids, add_sign (id,ty) sgn))
+    sign
+    (x,[],nil_sign)
+*)
+
+(* Expanding existential variables (pretyping.ml) *)
+(* 1- whd_ise fails if an existential is undefined *)
+
+exception Uninstantiated_evar of existential_key
+
+let rec whd_ise sigma c =
+  match kind_of_term c with
+    | Evar (ev,args) when Evd.in_dom sigma ev ->
+	if Evd.is_defined sigma ev then
+          whd_ise sigma (existential_value sigma (ev,args))
+	else raise (Uninstantiated_evar ev)
+  | _ -> c
+
+
+(* Expand evars, possibly in the head of an application *)
+let whd_castappevar_stack sigma c = 
+  let rec whrec (c, l as s) =
+    match kind_of_term c with
+      | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> 
+	  whrec (existential_value sigma (ev,args), l)
+      | Cast (c,_) -> whrec (c, l)
+      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
+      | _ -> s
+  in 
+  whrec (c, [])
+
+let whd_castappevar sigma c = applist (whd_castappevar_stack sigma c)
+
+let nf_evar = Pretype_errors.nf_evar
+let j_nf_evar = Pretype_errors.j_nf_evar
+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
+
+(**********************)
+(* Creating new evars *)
+(**********************)
+
+let evar_env evd = Global.env_of_context evd.evar_hyps
+
+(* Generator of existential names *)
+let new_evar =
+  let evar_ctr = ref 0 in
+  fun () -> incr evar_ctr; existential_of_int !evar_ctr
+
+let make_evar_instance env =
+  fold_named_context
+    (fun env (id, b, _) l -> (*if b=None then*) mkVar id :: l (*else l*))
+    env ~init:[]
+
+(* create an untyped existential variable *)
+let new_evar_in_sign env =
+  let ev = new_evar () in
+  mkEvar (ev, Array.of_list (make_evar_instance env))
+
+(*------------------------------------*
+ * functional operations on evar sets *
+ *------------------------------------*)
+
+(* All ids of sign must be distincts! *)
+let new_isevar_sign env sigma typ instance =
+  let sign = named_context env in
+  if not (list_distinct (ids_of_named_context sign)) then 
+    error "new_isevar_sign: two vars have the same name";
+  let newev = new_evar() in
+  let info = { evar_concl = typ; evar_hyps = sign; 
+	       evar_body = Evar_empty } in
+  (Evd.add sigma newev info, mkEvar (newev,Array.of_list instance))
+
+(* We don't try to guess in which sort the type should be defined, since
+   any type has type Type. May cause some trouble, but not so far... *)
+let new_Type () = mkType (new_univ ())
+
+let new_Type_sort () = Type (new_univ ())
+
+let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
+(*
+let new_Type () = mkType dummy_univ
+
+let new_Type_sort () = Type dummy_univ
+
+let judge_of_new_Type () = 
+  { uj_val = mkSort (Type dummy_univ);
+    uj_type = mkSort (Type dummy_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 modified = ref false in
+  let rec refresh t = match kind_of_term t with
+    | Sort (Type _) -> 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
+
+(* Declaring any type to be in the sort Type shouldn't be harmful since
+   cumulativity now includes Prop and Set in Type. *)
+let new_type_var env sigma =
+  let instance = make_evar_instance env in
+  new_isevar_sign env sigma (new_Type ()) instance
+
+let split_evar_to_arrow sigma (ev,args) =
+  let evd = Evd.map sigma ev in
+  let evenv = evar_env evd in
+  let (sigma1,dom) = new_type_var evenv sigma in
+  let hyps = evd.evar_hyps in
+  let nvar = next_ident_away (id_of_string "x") (ids_of_named_context hyps) in
+  let newenv = push_named (nvar, None, dom) evenv in
+  let (sigma2,rng) = new_type_var newenv sigma1 in
+  let x = named_hd newenv dom Anonymous in
+  let prod = mkProd (x, dom, subst_var nvar rng) in
+  let sigma3 = Evd.define sigma2 ev prod in
+  let evdom = fst (destEvar dom), args in
+  let evrng =
+    fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let prod' = mkProd (x, mkEvar evdom, mkEvar evrng) in
+  (sigma3,prod', evdom, evrng)
+
+(* 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. *)
+
+let do_restrict_hyps sigma ev args =
+  let args = Array.to_list args in
+  let evd = Evd.map sigma ev in
+  let env = evar_env evd in
+  let hyps = evd.evar_hyps in
+  let (_,(rsign,ncargs)) =
+    List.fold_left 
+      (fun (sign,(rs,na)) a ->
+	 (List.tl sign,
+	  if not(closed0 a) then 
+	    (rs,na)
+	  else 
+	    (add_named_decl (List.hd sign) rs, a::na)))
+      (hyps,([],[])) args 
+  in
+  let sign' = List.rev rsign in
+  let env' = reset_with_named_context sign' env in
+  let instance = make_evar_instance env' in
+  let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl instance in
+  let nc = refresh_universes nc in (* needed only if nc is an inferred type *)
+  let sigma'' = Evd.define sigma' ev nc in
+  (sigma'', nc)
+
+
+
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+type evar_constraint = conv_pb * constr * constr
+type evar_defs =
+    { mutable evars : Evd.evar_map;
+      mutable conv_pbs : evar_constraint list;
+      mutable history : (existential_key * (loc * Rawterm.hole_kind)) list }
+
+let create_evar_defs evd = { evars=evd; conv_pbs=[]; history=[] }
+let evars_of d = d.evars
+let evars_reset_evd evd d = d.evars <- evd
+let add_conv_pb d pb = d.conv_pbs <- pb::d.conv_pbs
+let evar_source ev d =
+  try List.assoc ev d.history
+  with Failure _ -> (dummy_loc, Rawterm.InternalHole)
+
+(* ise_try [f1;...;fn] tries fi() for i=1..n, restoring the evar constraints
+ * when fi returns false or an exception. Returns true if one of the fi
+ * returns true, and false if every fi return false (in the latter case,
+ * the evar constraints are restored).
+ *)
+let ise_try isevars l =
+  let u = isevars.evars in
+  let rec test = function
+      [] -> isevars.evars <- u; false
+    | f::l ->
+ 	  (try f() with reraise -> isevars.evars <- u; raise reraise)
+       or (isevars.evars <- u; test l)
+  in test l
+
+
+
+(* say if the section path sp corresponds to an existential *)
+let ise_in_dom isevars sp = Evd.in_dom isevars.evars sp
+
+(* map the given section path to the enamed_declaration *)
+let ise_map isevars sp = Evd.map isevars.evars sp
+
+(* define the existential of section path sp as the constr body *)
+let ise_define isevars sp body =
+  let body = refresh_universes body in (* needed only if an inferred type *)
+  isevars.evars <- Evd.define isevars.evars sp body
+
+let is_defined_evar isevars (n,_) = Evd.is_defined isevars.evars n
+
+(* Does k corresponds to an (un)defined existential ? *)
+let ise_undefined isevars c = match kind_of_term c with
+  | Evar ev -> not (is_defined_evar isevars ev)
+  | _ -> false
+
+let need_restriction isevars args = not (array_for_all closed0 args)
+    
+
+(* We try to instanciate the evar assuming the body won't depend
+ * on arguments that are not Rels or Vars, or appearing several times.
+ *)
+(* 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 real_clean env isevars ev args rhs =
+  let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in
+  let rec subs 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 -> t)
+      | Evar (ev,args) ->
+	  let args' = Array.map (subs k) args in
+	  if need_restriction isevars args' then
+	    if Evd.is_defined isevars.evars ev then 
+	      subs k (existential_value isevars.evars (ev,args'))
+	    else begin
+	      let (sigma,rc) = do_restrict_hyps isevars.evars ev args' in
+	      isevars.evars <- sigma;
+              isevars.history <- 
+                (fst (destEvar rc),evar_source ev isevars)::isevars.history;
+	      rc
+	    end
+	  else
+	    mkEvar (ev,args')
+      | Var _ -> (try List.assoc t subst with Not_found -> t)
+      | _ -> map_constr_with_binders succ subs k t
+  in
+  let body = subs 0 rhs in
+  if not (closed0 body)
+  then error_not_clean env isevars.evars ev body (evar_source ev isevars);
+  body
+
+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 as g) ->
+       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 *)
+(* Converting the env into the sign of the evar to define *)
+
+let push_rel_context_to_named_context env =
+  let sign0 = named_context env in
+  let (subst,_,sign) =
+  Sign.fold_rel_context
+    (fun (na,c,t) (subst,avoid,sign) ->
+       let na = if na = Anonymous then Name(id_of_string"_") else na in
+       let id = next_name_away na avoid in
+       ((mkVar id)::subst,
+        id::avoid,
+	add_named_decl (id,option_app (substl subst) c,
+                        type_app (substl subst) t)
+	  sign))
+    (rel_context env) ~init:([],ids_of_named_context sign0,sign0)
+  in (subst, reset_with_named_context sign env)
+
+let new_isevar isevars env src typ =
+  let subst,env' = push_rel_context_to_named_context env in
+  let typ' = substl subst typ in
+  let instance = make_evar_instance_with_rel env in
+  let (sigma',evar) = new_isevar_sign env' isevars.evars typ' instance in
+  isevars.evars <- sigma';
+  isevars.history <- (fst (destEvar evar),src)::isevars.history;
+  evar
+
+(* [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.
+ *
+ * If after cleaning, some free vars still occur, the function [restrict_hyps]
+ * tries to narrow the env of the evars that depend on Rels.
+ *
+ * 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
+ *)
+
+let evar_define env isevars (ev,argsv) rhs =
+  if occur_evar ev rhs
+  then error_occur_check env (evars_of isevars) ev rhs;
+  let args = Array.to_list argsv in 
+  let evd = ise_map isevars ev in
+  (* the bindings to invert *)
+  let worklist = make_subst (evar_env evd) args in
+  let body = real_clean env isevars ev worklist rhs in
+  ise_define isevars ev body;
+  [ev]
+
+(*-------------------*)
+(* Auxiliary functions for the conversion algorithms modulo evars
+ *)
+
+let has_undefined_isevars isevars t = 
+  try let _ = local_strong (whd_ise isevars.evars) t in false
+  with Uninstantiated_evar _ -> true
+
+let head_is_evar isevars = 
+  let rec hrec k = match kind_of_term k with
+    | Evar (n,_)   -> not (Evd.is_defined isevars.evars 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 head_evar = 
+  let rec hrec c = match kind_of_term c with
+    | Evar (ev,_)       -> ev
+    | Case (_,_,c,_) -> hrec c
+    | App (c,_)        -> hrec c
+    | Cast (c,_)        -> hrec c
+    | _                   -> failwith "headconstant"
+  in 
+  hrec 
+
+(* This code (i.e. solve_pb, etc.) takes a unification
+ * problem, and tries to solve it. If it solves it, then it removes
+ * all the conversion problems, and re-runs conversion on each one, in
+ * the hopes that the new solution will aid in solving them.
+ *
+ * The kinds of problems it knows how to solve are those in which
+ * the usable arguments of an existential var are all themselves
+ * universal variables.
+ * The solution to this problem is to do renaming for the Var's,
+ * to make them match up with the Var's which are found in the
+ * hyps of the existential, to do a "pop" for each Rel which is
+ * not an argument of the existential, and a subst1 for each which
+ * is, again, with the corresponding variable. This is done by
+ * evar_define
+ *
+ * Thus, we take the arguments of the existential which we are about
+ * to assign, and zip them with the identifiers in the hypotheses.
+ * Then, we process all the Var's in the arguments, and sort the
+ * Rel's into ascending order.  Then, we just march up, doing
+ * subst1's and pop's.
+ *
+ * NOTE: We can do this more efficiently for the relative arguments,
+ * by building a long substituend by hand, but this is a pain in the
+ * ass.
+ *)
+
+let status_changed lev (pbty,t1,t2) =
+  try 
+    List.mem (head_evar t1) lev or List.mem (head_evar t2) lev
+  with Failure _ ->
+    try List.mem (head_evar t2) lev with Failure _ -> false
+
+let get_changed_pb isevars lev =
+  let (pbs,pbs1) = 
+    List.fold_left
+      (fun (pbs,pbs1) pb ->
+    	 if status_changed lev pb then 
+	   (pb::pbs,pbs1)
+         else 
+	   (pbs,pb::pbs1))
+      ([],[])
+      isevars.conv_pbs
+  in
+  isevars.conv_pbs <- pbs1;
+  pbs
+
+(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
+ * definitions. We try to unify the xi with the yi pairwise. The pairs
+ * 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 [] else
+  let evd = Evd.map isevars.evars ev in
+  let hyps = evd.evar_hyps in
+  let (_,rsign) = 
+    array_fold_left2
+      (fun (sgn,rsgn) a1 a2 ->
+	 if conv_algo env isevars CONV a1 a2 then 
+	   (List.tl sgn, add_named_decl (List.hd sgn) rsgn)
+	 else 
+	   (List.tl  sgn, rsgn))
+      (hyps,[]) argsv1 argsv2 
+  in
+  let nsign = List.rev rsign in
+  let nargs = (Array.of_list (List.map mkVar (ids_of_named_context nsign))) in
+  let newev = new_evar () in
+  let info = { evar_concl = evd.evar_concl; evar_hyps = nsign;
+	       evar_body = Evar_empty } in
+  isevars.evars <-
+    Evd.define (Evd.add isevars.evars newev info) ev (mkEvar (newev,nargs));
+  isevars.history <- (newev,evar_source ev isevars)::isevars.history;
+  [ev]
+
+
+(* Tries to solve problem t1 = t2.
+ * Precondition: t1 is an uninstanciated evar
+ * Returns an optional list of evars that were instantiated, or None
+ * 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 t2 = nf_evar isevars.evars t2 in
+  let lsp = match kind_of_term t2 with
+    | Evar (n2,args2 as ev2)
+        when not (Evd.is_defined isevars.evars n2) ->
+	if n1 = n2 then
+	  solve_refl conv_algo env isevars n1 args1 args2
+	else
+	  if Array.length args1 < Array.length args2 then 
+	    evar_define env isevars ev2 (mkEvar ev1)
+	  else 
+	    evar_define env isevars ev1 t2
+    | _ ->
+	evar_define env isevars ev1 t2 in
+  let pbs = get_changed_pb isevars lsp in
+  List.for_all (fun (pbty,t1,t2) -> conv_algo env isevars pbty t1 t2) pbs
+
+(* Operations on value/type constraints *)
+
+type type_constraint = constr option
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ *   (false,(None,None)) -> no constraint at all
+ *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
+ *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
+ *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+let mk_valcon c = Some c
+
+(* Refining an evar to a product or a sort *)
+
+let refine_evar_as_arrow isevars ev =
+  let (sigma,prod,evdom,evrng) = split_evar_to_arrow isevars.evars ev in
+  evars_reset_evd sigma isevars;
+  let hst = evar_source (fst ev) isevars in
+  isevars.history <- (fst evrng,hst)::(fst evdom, hst)::isevars.history;
+  (prod,evdom,evrng)
+
+let define_evar_as_arrow isevars ev =
+  let (prod,_,_) = refine_evar_as_arrow isevars ev in
+  prod
+
+let define_evar_as_sort isevars (ev,args) =
+  let s = new_Type () in
+  let sigma' = Evd.define isevars.evars ev s in
+  evars_reset_evd sigma' isevars;
+  destSort s
+
+
+(* Propagation of constraints through application and abstraction:
+   Given a type constraint on a functional term, returns the type
+   constraint on its domain and codomain. If the input constraint is
+   an evar instantiate it with the product of 2 new evars. *)
+
+let split_tycon loc env isevars = function
+  | None -> Anonymous,None,None
+  | Some c ->
+      let sigma = evars_of isevars in
+      let t = whd_betadeltaiota env sigma c in
+      match kind_of_term t with
+        | Prod (na,dom,rng) -> na, Some dom, Some rng
+	| Evar (n,_ as ev) when not (Evd.is_defined isevars.evars n) ->
+	    let (_,evdom,evrng) = refine_evar_as_arrow isevars ev in
+	    Anonymous, Some (mkEvar evdom), Some (mkEvar evrng)
+	| _ -> error_not_product_loc loc env sigma c
+
+let valcon_of_tycon x = x
+
+let lift_tycon = option_app (lift 1)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
new file mode 100644
index 00000000..011d2a92
--- /dev/null
+++ b/pretyping/evarutil.mli
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  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: evarutil.mli,v 1.33.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Rawterm
+open Term
+open Sign
+open Evd
+open Environ
+open Reductionops
+(*i*)
+
+(*s This modules provides useful functions for unification modulo evars *)
+
+(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
+(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+
+val nf_evar :  evar_map -> constr -> constr
+val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar :
+   evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar :
+   evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar :
+   evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+(* Replacing all evars *)
+exception Uninstantiated_evar of existential_key
+val whd_ise :  evar_map -> constr -> constr
+val whd_castappevar :  evar_map -> constr -> constr
+
+(* Creating new existential variables *)
+val new_evar : unit -> evar
+val new_evar_in_sign : env -> constr
+
+val evar_env :  evar_info -> env
+
+type evar_defs
+val evars_of :  evar_defs ->  evar_map
+val create_evar_defs :  evar_map ->  evar_defs
+val evars_reset_evd :  evar_map ->  evar_defs -> unit
+val evar_source : existential_key -> evar_defs -> loc * hole_kind
+
+type evar_constraint = conv_pb * constr * constr
+val add_conv_pb :  evar_defs -> evar_constraint -> unit
+
+val is_defined_evar :  evar_defs -> existential -> bool
+val ise_try :  evar_defs -> (unit -> bool) list -> bool
+val ise_undefined :  evar_defs -> constr -> bool
+val has_undefined_isevars :  evar_defs -> constr -> bool
+
+val new_isevar_sign :
+ Environ.env -> Evd.evar_map -> Term.constr -> Term.constr list ->
+  Evd.evar_map * Term.constr
+
+val new_isevar :  evar_defs -> env -> loc * hole_kind -> constr -> constr
+
+val is_eliminator : constr -> bool
+val head_is_embedded_evar :  evar_defs -> constr -> bool
+val solve_simple_eqn :
+  (env ->  evar_defs -> conv_pb -> constr -> constr -> bool)
+  -> env ->  evar_defs -> conv_pb * existential * constr -> bool
+
+val define_evar_as_arrow : evar_defs -> existential -> types
+val define_evar_as_sort : evar_defs -> existential -> sorts
+
+(* Value/Type constraints *)
+
+val new_Type_sort : unit -> sorts
+val new_Type : unit -> constr
+val judge_of_new_Type : unit -> unsafe_judgment
+val refresh_universes : types -> types
+
+type type_constraint = constr option
+type val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : constr -> type_constraint
+val empty_valcon : val_constraint
+val mk_valcon : constr -> val_constraint
+
+val split_tycon :
+  loc -> env ->  evar_defs -> type_constraint -> 
+    name * type_constraint * type_constraint
+
+val valcon_of_tycon : type_constraint -> val_constraint
+
+val lift_tycon : type_constraint -> type_constraint
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
new file mode 100644
index 00000000..7a3e7c02
--- /dev/null
+++ b/pretyping/evd.ml
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: evd.ml,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Sign
+
+(* The type of mappings for existential variables *)
+
+type evar = existential_key
+
+type evar_body =
+  | Evar_empty 
+  | Evar_defined of constr
+
+type evar_info = {
+  evar_concl : constr;
+  evar_hyps : named_context;
+  evar_body : evar_body}
+
+module Evarmap = Intmap
+
+type evar_map = evar_info Evarmap.t
+
+let empty = Evarmap.empty
+
+let to_list evc = Evarmap.fold (fun ev x acc -> (ev,x)::acc) evc []
+let dom evc = Evarmap.fold (fun ev _ acc -> ev::acc) evc []
+let map evc k = Evarmap.find k evc
+let rmv evc k = Evarmap.remove k evc
+let remap evc k i = Evarmap.add k i evc
+let in_dom evc k = Evarmap.mem k evc
+
+let add evd ev newinfo =  Evarmap.add ev newinfo evd
+
+let define evd ev body = 
+  let oldinfo = map evd ev in
+  let newinfo =
+    { evar_concl = oldinfo.evar_concl;
+      evar_hyps = oldinfo.evar_hyps;
+      evar_body = Evar_defined body} 
+  in
+  match oldinfo.evar_body with
+    | Evar_empty -> Evarmap.add ev newinfo evd
+    | _ -> anomaly "cannot define an isevar twice"
+
+(* The list of non-instantiated existential declarations *)
+
+let non_instantiated sigma = 
+  let listev = to_list sigma in
+  List.fold_left 
+    (fun l ((ev,evd) as d) -> 
+       if evd.evar_body = Evar_empty then (d::l) else l)
+    [] listev
+    
+let is_evar sigma ev = in_dom sigma ev
+
+let is_defined sigma ev =
+  let info = map sigma ev in 
+  not (info.evar_body = Evar_empty)
+
+let evar_body ev = ev.evar_body
+
+let string_of_existential ev = "?" ^ string_of_int ev
+
+let existential_of_int ev = ev
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
new file mode 100644
index 00000000..f66667aa
--- /dev/null
+++ b/pretyping/evd.mli
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  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: evd.mli,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+(*i*)
+
+(* The type of mappings for existential variables.
+   The keys are integers and the associated information is a record
+   containing the type of the evar ([evar_concl]), the context under which 
+   it was introduced ([evar_hyps]) and its definition ([evar_body]). 
+   [evar_info] is used to add any other kind of information. *)
+
+type evar = existential_key
+
+type evar_body =
+  | Evar_empty 
+  | Evar_defined of constr
+
+type evar_info = {
+  evar_concl : constr;
+  evar_hyps : named_context;
+  evar_body : evar_body}
+
+type evar_map
+
+val empty : evar_map
+
+val add : evar_map -> evar -> evar_info -> evar_map
+
+val dom : evar_map -> evar list
+val map : evar_map -> evar -> evar_info
+val rmv : evar_map -> evar -> evar_map
+val remap : evar_map -> evar -> evar_info -> evar_map
+val in_dom : evar_map -> evar -> bool
+val to_list : evar_map -> (evar * evar_info) list
+
+val define : evar_map -> evar -> constr -> evar_map
+
+val non_instantiated : evar_map -> (evar * evar_info) list
+val is_evar : evar_map -> evar -> bool
+
+val is_defined : evar_map -> evar -> bool
+
+val evar_body : evar_info -> evar_body
+
+val string_of_existential : evar -> string
+val existential_of_int : int -> evar
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
new file mode 100644
index 00000000..0b9283ae
--- /dev/null
+++ b/pretyping/indrec.ml
@@ -0,0 +1,553 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: indrec.ml,v 1.20.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Termops
+open Declarations
+open Entries
+open Inductive
+open Inductiveops
+open Instantiate
+open Environ
+open Reductionops
+open Typeops
+open Type_errors
+open Indtypes (* pour les erreurs *)
+open Safe_typing
+open Nametab
+
+let make_prod_dep dep env = if dep then prod_name env else mkProd
+let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
+
+(*******************************************)
+(* Building curryfied elimination          *)
+(*******************************************)
+
+(**********************************************************************)
+(* Building case analysis schemes *)
+(* Nouvelle version, plus concise mais plus coûteuse à cause de
+   lift_constructor et lift_inductive_family qui ne se contentent pas de 
+   lifter les paramètres globaux *)
+
+let mis_make_case_com depopt env sigma (ind,mib,mip) kind =
+  let lnamespar = mip.mind_params_ctxt in
+  let dep = match depopt with 
+    | None -> mip.mind_sort <> (Prop Null)
+    | Some d -> d
+  in
+  if not (List.exists ((=) kind) mip.mind_kelim) then
+    raise
+      (InductiveError
+	 (NotAllowedCaseAnalysis
+	    (dep,(new_sort_in_family kind),ind)));
+
+  let nbargsprod = mip.mind_nrealargs + 1 in
+
+  (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
+  (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
+  let env' = push_rel_context lnamespar env in
+
+  let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in
+  let constrs = get_constructors env indf in
+
+  let rec add_branch env k = 
+    if k = Array.length mip.mind_consnames then
+      let nbprod = k+1 in
+      let indf = make_ind_family(ind,extended_rel_list nbprod lnamespar) in
+      let lnamesar,_ = get_arity env indf in
+      let ci = make_default_case_info env RegularStyle ind in
+      let depind = build_dependent_inductive env indf in
+      let deparsign = (Anonymous,None,depind)::lnamesar in
+      let p =
+      it_mkLambda_or_LetIn_name env'
+          (appvect
+            (mkRel ((if dep then nbargsprod else mip.mind_nrealargs) + nbprod),
+            if dep then extended_rel_vect 0 deparsign
+            else extended_rel_vect 0 lnamesar))
+          (if dep then deparsign else lnamesar) in
+      it_mkLambda_or_LetIn_name env'
+       	(mkCase (ci, lift nbargsprod p,
+		     mkRel 1,
+		     rel_vect nbargsprod k))
+       	deparsign
+    else
+      let cs = lift_constructor (k+1) constrs.(k) in
+      let t = build_branch_type env dep (mkRel (k+1)) cs in
+      mkLambda_string "f" t
+	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
+  in
+  let typP = make_arity env' dep indf (new_sort_in_family kind) in
+  it_mkLambda_or_LetIn_name env 
+    (mkLambda_string "P" typP
+       (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
+    
+(* check if the type depends recursively on one of the inductive scheme *)
+
+(**********************************************************************)
+(* Building the recursive elimination *)
+
+(*
+ * t is the type of the constructor co and recargs is the information on 
+ * the recursive calls. (It is assumed to be in form given by the user).
+ * build the type of the corresponding branch of the recurrence principle
+ * assuming f has this type, branch_rec gives also the term 
+ *   [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of 
+ * the case operation
+ * FPvect gives for each inductive definition if we want an elimination 
+ * on it with which predicate and which recursive function. 
+ *)
+
+let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = 
+  let make_prod = make_prod_dep dep in
+  let nparams = List.length vargs in
+  let process_pos env depK pk =
+    let rec prec env i sign p =
+      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      match kind_of_term p' with
+	| Prod (n,t,c) ->
+	    let d = (n,None,t) in
+	    make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
+	| LetIn (n,b,t,c) ->
+	    let d = (n,Some b,t) in
+	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
+     	| Ind (_,_) ->
+	    let realargs = list_skipn nparams largs in
+	    let base = applist (lift i pk,realargs) in
+            if depK then 
+	      Reduction.beta_appvect
+                base [|applist (mkRel (i+1),extended_rel_list 0 sign)|]
+            else 
+	      base
+      	| _ -> assert false 
+    in
+    prec env 0 []
+  in
+  let rec process_constr env i c recargs nhyps li =
+    if nhyps > 0 then match kind_of_term c with 
+      | Prod (n,t,c_0) ->
+          let (optionpos,rest) = 
+	    match recargs with 
+	      | [] -> None,[]
+              | ra::rest ->
+                  (match dest_recarg ra with 
+	            | Mrec j when is_rec -> (depPvect.(j),rest)
+	            | Imbr _  -> 
+		        Options.if_verbose warning "Ignoring recursive call"; 
+		        (None,rest) 
+                    | _ -> (None, rest))
+	  in 
+          (match optionpos with 
+	     | None -> 
+		 make_prod env
+		   (n,t,
+		    process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+		      (nhyps-1) (i::li))
+             | Some(dep',p) -> 
+		 let nP = lift (i+1+decP) p in
+                 let env' = push_rel (n,None,t) env in
+		 let t_0 = process_pos env' dep' nP (lift 1 t) in 
+		 make_prod_dep (dep or dep') env
+                   (n,t,
+		    mkArrow t_0
+		      (process_constr
+			(push_rel (Anonymous,None,t_0) env')
+			 (i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
+      | LetIn (n,b,t,c_0) ->
+	  mkLetIn (n,b,t,
+		   process_constr
+		     (push_rel (n,Some b,t) env)
+		     (i+1) c_0 recargs (nhyps-1) li)
+      | _ -> assert false
+    else
+      if dep then
+	let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in
+        let params = List.map (lift i) vargs in
+        let co = applist (mkConstruct cs.cs_cstr,params@realargs) in
+	Reduction.beta_appvect c [|co|]
+      else c
+  in
+  let nhyps = List.length cs.cs_args in
+  let nP = match depPvect.(tyi) with 
+    | Some(_,p) -> lift (nhyps+decP) p
+    | _ -> assert false in
+  let base = appvect (nP,cs.cs_concl_realargs) in
+  let c = it_mkProd_or_LetIn base cs.cs_args in
+  process_constr env 0 c recargs nhyps []
+
+let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = 
+  let process_pos env fk  =
+    let rec prec env i hyps p =
+      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      match kind_of_term p' with
+	| Prod (n,t,c) ->
+	    let d = (n,None,t) in
+	    lambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
+	| LetIn (n,b,t,c) ->
+	    let d = (n,Some b,t) in
+	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
+     	| Ind _ -> 
+            let realargs = list_skipn nparams largs
+            and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in 
+            applist(lift i fk,realargs@[arg])
+     	| _ -> assert false
+    in
+    prec env 0 []
+  in
+  (* ici, cstrprods est la liste des produits du constructeur instantié *)
+  let rec process_constr env i f = function
+    | (n,None,t as d)::cprest, recarg::rest -> 
+        let optionpos = 
+	  match dest_recarg recarg with 
+            | Norec   -> None
+            | Imbr _  -> None
+            | Mrec i  -> fvect.(i)
+	in 
+        (match optionpos with 
+           | None ->
+	       lambda_name env
+		 (n,t,process_constr (push_rel d env) (i+1)
+		    (whd_beta (applist (lift 1 f, [(mkRel 1)])))
+		    (cprest,rest))
+           | Some(_,f_0) -> 
+	       let nF = lift (i+1+decF) f_0 in
+               let env' = push_rel d env in
+	       let arg = process_pos env' nF (lift 1 t) in 
+               lambda_name env
+		 (n,t,process_constr env' (i+1)
+		    (whd_beta (applist (lift 1 f, [(mkRel 1); arg])))
+		    (cprest,rest)))
+    | (n,Some c,t as d)::cprest, rest ->
+	mkLetIn
+	  (n,c,t,
+	   process_constr (push_rel d env) (i+1) (lift 1 f)
+	     (cprest,rest))
+    | [],[] -> f
+    | _,[] | [],_ -> anomaly "process_constr"
+
+  in
+  process_constr env 0 f (List.rev cstr.cs_args, recargs)
+
+(* Main function *)
+let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
+  let nparams = mip.mind_nparams in
+  let lnamespar = mip.mind_params_ctxt in
+  let nrec = List.length listdepkind in
+  let depPvec =
+    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)
+    in 
+    assign nrec listdepkind in 
+  let recargsvec =
+    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+  let make_one_rec p =
+    let makefix nbconstruct =
+      let rec mrec i ln ltyp ldef = function
+	| (indi,mibi,mipi,dep,_)::rest ->
+	    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 *)
+	    let args = extended_rel_list (nrec+nbconstruct) lnamespar in
+	    let indf = make_ind_family(indi,args) in
+	    let lnames,_ = get_arity env indf in
+
+	    let nar = mipi.mind_nrealargs in
+	    let dect = nar+nrec+nbconstruct in
+
+	    let branches = 
+              (* 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+1) lnamespar in
+              let indf' = make_ind_family(indi,args') in
+	      let constrs = get_constructors env indf' in
+	      let vecfi = rel_vect (dect+1-i-nctyi) nctyi in
+	      array_map3
+		(make_rec_branch_arg env sigma (nparams,depPvec,nar+1))
+                vecfi constrs (dest_subterms recargsvec.(tyi)) in
+	    let j = (match depPvec.(tyi) with 
+		       | Some (_,c) when isRel c -> destRel c 
+		       | _ -> assert false) in
+	    let deftyi = 
+	      let ci = make_default_case_info env RegularStyle indi in
+	      let indf' = lift_inductive_family nrec indf in
+	      let depind = build_dependent_inductive env indf' in
+	      let lnames' = Termops.lift_rel_context nrec lnames in
+	      let p =
+		let arsign =
+		  if dep then (Anonymous,None,depind)::lnames' else lnames' in
+		it_mkLambda_or_LetIn_name env
+		  (appvect
+		    (mkRel ((if dep then 1 else 0) + dect + j),
+		    extended_rel_vect 0 arsign)) arsign
+	      in
+	      it_mkLambda_or_LetIn_name env
+		(lambda_create env
+		  (depind,mkCase (ci, lift (nar+1) p, mkRel 1, branches)))
+		lnames'
+	    in
+	    let typtyi = 
+	      let ind = build_dependent_inductive env indf in
+	      it_mkProd_or_LetIn_name env
+		(prod_create env
+		   (ind,
+		    (if dep then 
+		       let ext_lnames = (Anonymous,None,ind)::lnames in
+		       let args = extended_rel_list 0 ext_lnames in
+		       applist (mkRel (nbconstruct+nar+j+1), args)
+		     else
+		       let args = extended_rel_list 1 lnames in
+		       applist (mkRel (nbconstruct+nar+j+1), args))))
+          	lnames
+	    in 
+	    mrec (i+nctyi) (nar::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))
+      in 
+      mrec 0 [] [] [] 
+    in 
+    let rec make_branch env i = function 
+      | (indi,mibi,mipi,dep,_)::rest ->
+          let tyi = snd indi in
+	  let nconstr = Array.length mipi.mind_consnames in
+	  let rec onerec env j = 
+	    if j = nconstr then 
+	      make_branch env (i+j) rest 
+	    else 
+	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
+	      let vargs = extended_rel_list (nrec+i+j) lnamespar in
+	      let indf = (indi, vargs) in
+	      let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
+	      let p_0 =
+		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))
+	  in onerec env 0
+      | [] -> 
+	  makefix i listdepkind
+    in 
+    let rec put_arity env i = function 
+      | (indi,_,_,dep,kinds)::rest -> 
+	  let indf = make_ind_family (indi,extended_rel_list i lnamespar) 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)
+      | [] -> 
+	  make_branch env 0 listdepkind 
+    in 
+    let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
+    let env' = push_rel_context lnamespar env in
+    if mis_is_recursive_subset
+      (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
+      mipi.mind_recargs
+    then 
+      it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamespar
+    else 
+      mis_make_case_com (Some dep) env sigma (indi,mibi,mipi) kind 
+  in 
+  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
+
+let make_case_dep env   = make_case_com (Some true) env
+let make_case_nodep env = make_case_com (Some false) env 
+let make_case_gen env   = make_case_com None env
+
+
+(**********************************************************************)
+(* [instanciate_indrec_scheme s rec] replace the sort of the scheme
+   [rec] by [s] *)
+
+let change_sort_arity sort = 
+  let rec drec a = match kind_of_term a with
+    | Cast (c,t) -> drec c 
+    | Prod (n,t,c) -> mkProd (n, t, drec c)
+    | Sort _ -> mkSort sort
+    | _ -> assert false
+  in 
+  drec 
+
+(* [npar] is the number of expected arguments (then excluding letin's) *)
+let instanciate_indrec_scheme sort =
+  let rec drec npar elim =
+    match kind_of_term elim with
+      | Lambda (n,t,c) -> 
+	  if npar = 0 then 
+	    mkLambda (n, change_sort_arity sort t, c)
+	  else 
+	    mkLambda (n, t, drec (npar-1) c)
+      | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c)
+      | _ -> anomaly "instanciate_indrec_scheme: wrong elimination type"
+  in
+  drec
+
+(* Change the sort in the type of an inductive definition, builds the
+   corresponding eta-expanded term *)
+let instanciate_type_indrec_scheme sort npars term =
+  let rec drec np elim =
+    match kind_of_term elim with
+      | Prod (n,t,c) -> 
+	  if np = 0 then 
+            let t' = change_sort_arity sort t in
+            mkProd (n, t', c),
+            mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1)))
+	  else 
+            let c',term' = drec (np-1) c in
+	    mkProd (n, t, c'), mkLambda (n, t, term')
+      | LetIn (n,b,t,c) -> let c',term' = drec np c in
+           mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') 
+      | _ -> anomaly "instanciate_type_indrec_scheme: wrong elimination type"
+  in
+  drec npars
+
+(**********************************************************************)
+(* Interface to build complex Scheme *)
+
+let check_arities listdepkind = 
+  List.iter 
+    (function (indi,mibi,mipi,dep,kind) -> 
+       let id = mipi.mind_typename  in
+       let kelim = mipi.mind_kelim in
+       if not (List.exists ((=) kind) kelim) then
+	 raise
+	   (InductiveError (BadInduction (dep, id, new_sort_in_family kind))))
+    listdepkind
+
+let build_mutual_indrec env sigma = function 
+  | (mind,mib,mip,dep,s)::lrecspec ->
+      let (sp,tyi) = mind in
+      let listdepkind = 
+    	(mind,mib,mip, dep,s)::
+    	(List.map
+	   (function (mind',mibi',mipi',dep',s') ->
+	      let (sp',_) = mind' in
+	      if sp=sp' then 
+                let (mibi',mipi') = lookup_mind_specif env mind' in
+		(mind',mibi',mipi',dep',s') 
+	      else 
+		raise (InductiveError NotMutualInScheme))
+	   lrecspec)
+      in
+      let _ = check_arities listdepkind in 
+      mis_make_indrec env sigma listdepkind (mind,mib,mip)
+  | _ -> anomaly "build_indrec expects a non empty list of inductive types"
+
+let build_indrec env sigma ind =
+  let (mib,mip) = lookup_mind_specif env ind in
+  let kind = family_of_sort mip.mind_sort in
+  let dep = kind <> InProp in
+  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip))
+
+(**********************************************************************)
+(* To handle old Case/Match syntax in Pretyping                       *)
+
+(*****************************************)
+(* To interpret Case and Match operators *)
+(* Expects a dependent predicate *)
+
+let type_rec_branches recursive env sigma indt p c = 
+  let IndType (indf,realargs) = indt in
+  let (ind,params) = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let recargs = mip.mind_recargs in
+  let tyi = snd ind in
+  let init_depPvec i = if i = tyi then Some(true,p) else None in
+  let depPvec = Array.init mib.mind_ntypes init_depPvec in
+  let vargs = Array.of_list params in
+  let constructors = get_constructors env indf in
+  let lft =
+    array_map2
+      (type_rec_branch recursive true env sigma (params,depPvec,0) tyi)
+      constructors (dest_subterms recargs) in
+  (lft,Reduction.beta_appvect p (Array.of_list (realargs@[c])))
+(* Non recursive case. Pb: does not deal with unification
+    let (p,ra,_) = type_case_branches env (ind,params@realargs) pj c in
+    (p,ra)
+*)
+
+(*s Eliminations. *)
+
+let elimination_suffix = function
+  | InProp -> "_ind"
+  | InSet  -> "_rec"
+  | InType -> "_rect"
+
+let make_elimination_ident id s = add_suffix id (elimination_suffix s)
+
+(* Look up function for the default elimination constant *)
+
+let lookup_eliminator ind_sp s =
+  let kn,i = ind_sp in
+  let mp,dp,l = repr_kn kn in
+  let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in
+  let id = add_suffix ind_id (elimination_suffix s) in
+  (* Try first to get an eliminator defined in the same section as the *)
+  (* inductive type *)
+  let ref = ConstRef (make_kn mp dp (label_of_id id)) in
+  try 
+    let _ = sp_of_global ref in
+    constr_of_reference ref
+  with Not_found ->
+  (* Then try to get a user-defined eliminator in some other places *)
+  (* using short name (e.g. for "eq_rec") *)
+  try constr_of_reference (Nametab.locate (make_short_qualid id))
+  with Not_found ->
+    errorlabstrm "default_elim"
+      (str "Cannot find the elimination combinator " ++
+       pr_id id ++ spc () ++
+       str "The elimination of the inductive definition " ++
+       pr_id id ++ spc () ++ str "on sort " ++ 
+       spc () ++ print_sort_family s ++
+       str " is probably not allowed")
+
+
+(*  let env = Global.env() in
+  let path = sp_of_global None (IndRef ind_sp) in
+  let dir, base = repr_path path in
+  let id = add_suffix base (elimination_suffix s) in
+  (* Try first to get an eliminator defined in the same section as the *)
+  (* inductive type *)
+  try construct_absolute_reference (Names.make_path dir id)
+  with Not_found ->
+  (* Then try to get a user-defined eliminator in some other places *)
+  (* using short name (e.g. for "eq_rec") *)
+    try constr_of_reference (Nametab.locate (make_short_qualid id))
+    with Not_found ->
+      errorlabstrm "default_elim"
+	(str "Cannot find the elimination combinator " ++
+           pr_id id ++ spc () ++
+	   str "The elimination of the inductive definition " ++
+           pr_id base ++ spc () ++ str "on sort " ++ 
+           spc () ++ print_sort_family s ++
+	   str " is probably not allowed")
+*)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
new file mode 100644
index 00000000..f6f76706
--- /dev/null
+++ b/pretyping/indrec.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  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: indrec.mli,v 1.6.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Inductiveops
+open Environ
+open Evd
+(*i*)
+
+(* Eliminations. *)
+
+(* These functions build elimination predicate for Case tactic *)
+
+val make_case_dep : env -> evar_map -> inductive -> sorts_family -> constr
+val make_case_nodep : env -> evar_map -> inductive -> sorts_family -> constr
+val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr
+
+(* This builds an elimination scheme associated (using the own arity
+   of the inductive) *)
+
+val build_indrec : env -> evar_map -> inductive -> constr
+val instanciate_indrec_scheme : sorts -> int -> constr -> constr
+val instanciate_type_indrec_scheme : sorts -> int -> constr -> types ->
+  constr * types
+
+(* This builds complex [Scheme] *)
+
+val build_mutual_indrec : 
+  env -> evar_map ->
+    (inductive * mutual_inductive_body * one_inductive_body
+    * bool * sorts_family) list
+    -> constr list
+
+(* These are for old Case/Match typing *)
+
+val type_rec_branches : bool -> env -> evar_map -> inductive_type
+  -> constr -> constr -> constr array * constr
+val make_rec_branch_arg : 
+  env -> evar_map ->
+    int * ('b * constr) option array * int ->
+    constr -> constructor_summary -> wf_paths list -> constr
+
+(* *)
+val lookup_eliminator : inductive -> sorts_family -> constr
+val elimination_suffix : sorts_family -> string
+val make_elimination_ident : identifier -> sorts_family -> identifier
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
new file mode 100644
index 00000000..24a8fbc7
--- /dev/null
+++ b/pretyping/inductiveops.ml
@@ -0,0 +1,352 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: inductiveops.ml,v 1.14.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Termops
+open Sign
+open Declarations
+open Environ
+open Reductionops
+
+(* [inductive_family] = [inductive_instance] applied to global parameters *)
+type inductive_family = inductive * constr list
+
+let make_ind_family (mis, params) = (mis,params)
+let dest_ind_family (mis,params) = (mis,params)
+
+let map_ind_family f (mis,params) = (mis, List.map f params)
+
+let liftn_inductive_family n d = map_ind_family (liftn n d)
+let lift_inductive_family n = liftn_inductive_family n 1
+
+let substnl_ind_family l n = map_ind_family (substnl l n)
+
+
+type inductive_type = IndType of inductive_family * constr list
+
+let make_ind_type (indf, realargs) = IndType (indf,realargs)
+let dest_ind_type (IndType (indf,realargs)) = (indf,realargs)
+
+let map_inductive_type f (IndType (indf, realargs)) =
+  IndType (map_ind_family f indf, List.map f realargs)
+
+let liftn_inductive_type n d = map_inductive_type (liftn n d)
+let lift_inductive_type n = liftn_inductive_type n 1
+
+let substnl_ind_type l n = map_inductive_type (substnl l n)
+
+let mkAppliedInd (IndType ((ind,params), realargs)) =
+  applist (mkInd ind,params@realargs)
+
+
+(* Does not consider imbricated or mutually recursive types *) 
+let mis_is_recursive_subset listind rarg = 
+  let rec one_is_rec rvec = 
+    List.exists
+      (fun ra ->
+        match dest_recarg ra with
+	  | Mrec i -> List.mem i listind 
+          | _ -> false) rvec
+  in 
+  array_exists one_is_rec (dest_subterms rarg)
+
+let mis_is_recursive (ind,mib,mip) =
+  mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1))
+    mip.mind_recargs
+
+let mis_nf_constructor_type (ind,mib,mip) j =
+  let specif = mip.mind_nf_lc
+  and ntypes = mib.mind_ntypes
+  and nconstr = Array.length mip.mind_consnames in
+  let make_Ik k = mkInd ((fst ind),ntypes-k-1) in 
+  if j > nconstr then error "Not enough constructors in the type";
+  substl (list_tabulate make_Ik ntypes) specif.(j-1)
+
+(* Arity of constructors excluding parameters and local defs *)
+let mis_constr_nargs indsp =
+  let (mib,mip) = Global.lookup_inductive indsp in
+  let recargs = dest_subterms mip.mind_recargs in
+  Array.map List.length recargs
+
+let mis_constr_nargs_env env (kn,i) = 
+  let mib = Environ.lookup_mind kn env in
+  let mip = mib.mind_packets.(i) in 
+  let recargs = dest_subterms mip.mind_recargs in
+  Array.map List.length recargs
+
+let mis_constructor_nargs_env env ((kn,i),j) =
+  let mib = Environ.lookup_mind kn env in
+  let mip = mib.mind_packets.(i) in 
+  recarg_length mip.mind_recargs j + mip.mind_nparams
+
+(* Annotation for cases *)
+let make_case_info env ind style pats_source =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let print_info =
+    { ind_nargs = mip.mind_nrealargs;
+      style     = style;
+      source    = pats_source } in
+  { ci_ind     = ind;
+    ci_npar    = mip.mind_nparams;
+    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 *)
+
+type constructor_summary = {
+  cs_cstr : constructor;
+  cs_params : constr list;
+  cs_nargs : int;
+  cs_args : rel_context;
+  cs_concl_realargs : constr array
+}
+
+let lift_constructor n cs = {
+  cs_cstr = cs.cs_cstr;
+  cs_params = List.map (lift n) cs.cs_params;
+  cs_nargs = cs.cs_nargs;
+  cs_args = lift_rel_context n cs.cs_args;
+  cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
+}
+
+let instantiate_params t args sign =
+  let rec inst s t = function
+    | ((_,None,_)::ctxt,a::args) ->
+	(match kind_of_term t with
+	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
+	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
+    | ((_,(Some b),_)::ctxt,args) -> 
+	(match kind_of_term t with
+	   | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
+	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
+    | [], [] -> substl s t
+    | _ -> anomaly"instantiate_params: type, ctxt and args mismatch"
+  in inst [] t (List.rev sign,args)
+
+let get_constructor (ind,mib,mip,params) j =
+  assert (j <= Array.length mip.mind_consnames);
+  let typi = mis_nf_constructor_type (ind,mib,mip) j in
+  let typi = instantiate_params typi params mip.mind_params_ctxt in
+  let (args,ccl) = decompose_prod_assum typi in
+  let (_,allargs) = decompose_app ccl in
+  let vargs = list_skipn mip.mind_nparams allargs in
+  { cs_cstr = ith_constructor_of_inductive ind j;
+    cs_params = params;
+    cs_nargs = rel_context_length args;
+    cs_args = args;
+    cs_concl_realargs = Array.of_list vargs }
+
+let get_constructors env (ind,params) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  Array.init (Array.length mip.mind_consnames)
+    (fun j -> get_constructor (ind,mib,mip,params) (j+1))
+
+let rec instantiate args c = match kind_of_term c, args with
+  | Prod (_,_,c), a::args -> instantiate args (subst1 a c)
+  | LetIn (_,b,_,c), args -> instantiate args (subst1 b c)
+  | _, [] -> c
+  | _ -> anomaly "too short arity"
+
+let get_arity env (ind,params) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let arity = mip.mind_nf_arity in
+  destArity (instantiate params arity)
+
+(* Functions to build standard types related to inductive *)
+let build_dependent_constructor cs =
+  applist
+    (mkConstruct cs.cs_cstr,
+     (List.map (lift cs.cs_nargs) cs.cs_params)
+      @(extended_rel_list 0 cs.cs_args))
+
+let build_dependent_inductive env ((ind, params) as indf) =
+  let arsign,_ = get_arity env indf in
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let nrealargs = mip.mind_nrealargs in
+  applist 
+    (mkInd ind,
+     (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+
+(* builds the arity of an elimination predicate in sort [s] *)
+
+let make_arity_signature env dep indf =
+  let (arsign,_) = get_arity env indf in
+  if dep then
+    (* We need names everywhere *)
+    name_context env
+      ((Anonymous,None,build_dependent_inductive env indf)::arsign)
+      (* Costly: would be better to name one for all at definition time *)
+  else
+    (* No need to enforce names *)
+    arsign
+
+let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s)
+
+(* [p] is the predicate and [cs] a constructor summary *)
+let build_branch_type env dep p cs =
+  let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in
+  if dep then
+    it_mkProd_or_LetIn_name env
+      (applist (base,[build_dependent_constructor cs]))
+      cs.cs_args
+  else
+    it_mkProd_or_LetIn base cs.cs_args
+
+(**************************************************)
+
+let extract_mrectype t =
+  let (t, l) = decompose_app t in
+  match kind_of_term t with
+    | Ind ind -> (ind, l)
+    | _ -> raise Not_found
+
+let find_mrectype env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind -> (ind, l)
+    | _ -> raise Not_found
+
+let find_rectype env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind ->
+        let (mib,mip) = Inductive.lookup_mind_specif env ind in
+        let (par,rargs) = list_chop mip.mind_nparams l in
+        IndType((ind, par),rargs)
+    | _ -> raise Not_found
+
+let find_inductive env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind
+        when (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        (ind, l)
+    | _ -> raise Not_found
+
+let find_coinductive env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind
+        when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        (ind, l)
+    | _ -> raise Not_found
+
+
+(***********************************************)
+(* find appropriate names for pattern variables. Useful in the
+   Case tactic. *)
+
+let is_dep_predicate env kelim pred nodep_ar = 
+  let rec srec env pval pt nodep_ar =
+    let pt' = whd_betadeltaiota env Evd.empty pt in
+    let pv' = whd_betadeltaiota env Evd.empty pval in
+    match kind_of_term pv', kind_of_term pt', kind_of_term nodep_ar with
+      | Lambda (na,t,b), Prod (_,_,a), Prod (_,_,a') ->
+	  srec (push_rel_assum (na,t) env) b a a'
+      | _,              Prod (na,t,a), Prod (_,_,a') ->
+	  srec (push_rel_assum (na,t) env) (lift 1 pv') a a'
+      | Lambda (_,_,b), Prod (_,_,_), _ -> (*dependent (mkRel 1) b*) true
+      | _, Prod (_,_,_), _ -> true
+      | _ -> false in 
+  srec env pred.uj_val pred.uj_type nodep_ar
+
+let is_dependent_elimination_predicate env pred indf =
+  let (ind,params) = indf in
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  let kelim = mip.mind_kelim in
+  let arsign,s = get_arity env indf in
+  let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
+  is_dep_predicate env kelim pred glob_t
+
+let is_dep_arity env kelim predty nodep_ar = 
+  let rec srec pt nodep_ar =
+    let pt' = whd_betadeltaiota env Evd.empty pt in
+    match kind_of_term pt', kind_of_term nodep_ar with
+      | Prod (_,a1,a2), Prod (_,a1',a2') -> srec a2 a2'
+      | Prod (_,a1,a2), _ -> true
+      | _ -> false in 
+  srec predty nodep_ar
+
+let is_dependent_elimination env predty indf =
+  let (ind,params) = indf in
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  let kelim = mip.mind_kelim in
+  let arsign,s = get_arity env indf in
+  let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
+  is_dep_arity env kelim predty glob_t
+
+let set_names env n brty =
+  let (ctxt,cl) = decompose_prod_n_assum n brty in
+  it_mkProd_or_LetIn_name env cl ctxt
+
+let set_pattern_names env ind brv =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  let arities =
+    Array.map
+      (fun c ->
+        rel_context_length (fst (decompose_prod_assum c)) -
+        mip.mind_nparams)
+      mip.mind_nf_lc in
+  array_map2 (set_names env) arities brv
+
+
+let type_case_branches_with_names env indspec pj c =
+  let (ind,args) = indspec in
+  let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let params = list_firstn mip.mind_nparams args in
+  if is_dependent_elimination_predicate env pj (ind,params) then
+    (set_pattern_names env ind lbrty, conclty)
+  else (lbrty, conclty)
+
+(* Type of Case predicates *)
+let arity_of_case_predicate env (ind,params) dep k =
+  let arsign,_ = get_arity env (ind,params) in
+  let mind = build_dependent_inductive env (ind,params) in
+  let concl = if dep then mkArrow mind (mkSort k) else mkSort k in
+  it_mkProd_or_LetIn concl arsign
+
+(***********************************************)
+(* Guard condition *)
+
+(* 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 (_,cl)         -> 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 
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
new file mode 100644
index 00000000..a8dcef29
--- /dev/null
+++ b/pretyping/inductiveops.mli
@@ -0,0 +1,93 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: inductiveops.mli,v 1.10.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Evd
+
+(* An inductive type with its parameters *)
+type inductive_family
+val make_ind_family : inductive * constr list -> inductive_family
+val dest_ind_family : inductive_family -> inductive * constr list
+val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family
+val liftn_inductive_family : int -> int -> inductive_family -> inductive_family
+val lift_inductive_family  : int -> inductive_family -> inductive_family
+val substnl_ind_family :
+  constr list -> int -> inductive_family -> inductive_family
+
+(* An inductive type with its parameters and real arguments *)
+type inductive_type = IndType of inductive_family * constr list
+val make_ind_type : inductive_family * constr list -> inductive_type
+val dest_ind_type : inductive_type -> inductive_family * constr list
+val map_inductive_type : (constr -> constr) -> inductive_type -> inductive_type
+val liftn_inductive_type : int -> int -> inductive_type -> inductive_type
+val lift_inductive_type  : int -> inductive_type -> inductive_type
+val substnl_ind_type :
+  constr list -> int -> inductive_type -> inductive_type
+
+val mkAppliedInd : inductive_type -> constr
+val mis_is_recursive_subset : int list -> wf_paths -> bool
+val mis_is_recursive :
+  inductive * mutual_inductive_body * one_inductive_body -> bool
+val mis_nf_constructor_type :
+  inductive * mutual_inductive_body * one_inductive_body -> int -> constr
+val mis_constr_nargs : inductive -> int array
+
+val mis_constr_nargs_env : env -> inductive -> int array
+
+val mis_constructor_nargs_env : env -> constructor -> int
+
+type constructor_summary = {
+  cs_cstr : constructor;
+  cs_params : constr list;
+  cs_nargs : int;
+  cs_args : Sign.rel_context;
+  cs_concl_realargs : constr array;
+} 
+val lift_constructor : int -> constructor_summary -> constructor_summary
+val get_constructor :
+  inductive * mutual_inductive_body * one_inductive_body * constr list ->
+  int -> constructor_summary
+val get_arity        : env -> inductive_family -> Sign.arity
+val get_constructors : env -> inductive_family -> constructor_summary array
+val build_dependent_constructor : constructor_summary -> constr
+val build_dependent_inductive   : env -> inductive_family -> constr
+val make_arity_signature :
+  env -> bool -> inductive_family -> Sign.rel_context
+val make_arity : env -> bool -> inductive_family -> sorts -> types
+val build_branch_type : env -> bool -> constr -> constructor_summary -> types
+
+(* Raise Not_found if not given an valid inductive type *)
+val extract_mrectype : constr -> inductive * constr list
+val find_mrectype    : env -> evar_map -> constr -> inductive * constr list
+val find_rectype     : env -> evar_map -> constr -> inductive_type
+val find_inductive   : env -> evar_map -> constr -> inductive * constr list
+val find_coinductive : env -> evar_map -> constr -> inductive * constr list
+
+(********************)
+(* Determines if a case predicate type corresponds to dependent elimination *)
+val is_dependent_elimination :
+  env -> types -> inductive_family -> bool
+
+(* Builds the case predicate arity (dependent or not) *)
+val arity_of_case_predicate :
+  env -> inductive_family -> bool -> sorts -> types
+
+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_default_case_info : env -> case_style -> inductive -> case_info
+
+(********************)
+val control_only_guard : env -> types -> unit
diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml
new file mode 100644
index 00000000..702cdfea
--- /dev/null
+++ b/pretyping/instantiate.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: instantiate.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Evd
+open Declarations
+open Environ
+
+let is_id_inst inst =
+  let is_id (id,c) = match kind_of_term c with
+    | Var id' -> id = id'
+    | _ -> false
+  in
+  List.for_all is_id inst
+
+(* Vérifier que les instances des let-in sont compatibles ?? *)
+let instantiate_sign_including_let sign args =
+  let rec instrec = function
+    | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
+    | ([],[])                        -> []
+    | ([],_) | (_,[]) ->
+    anomaly "Signature and its instance do not match"
+  in 
+  instrec (sign,args)
+
+let instantiate_evar sign c args =
+  let inst = instantiate_sign_including_let sign args in
+  if is_id_inst inst then
+    c
+  else
+    replace_vars inst c
+
+(* Existentials. *)
+
+let existential_type sigma (n,args) =
+  let info =
+    try Evd.map sigma n
+    with Not_found ->
+      anomaly ("Evar "^(string_of_existential n)^" was not declared") in
+  let hyps = info.evar_hyps in
+  instantiate_evar hyps info.evar_concl (Array.to_list args)
+
+exception NotInstantiatedEvar
+
+let existential_value sigma (n,args) =
+  let info = Evd.map sigma n in
+  let hyps = info.evar_hyps in
+  match evar_body info with
+    | Evar_defined c ->
+	instantiate_evar hyps c (Array.to_list args)
+    | Evar_empty ->
+	raise NotInstantiatedEvar
+
+let existential_opt_value sigma ev =
+  try Some (existential_value sigma ev)
+  with NotInstantiatedEvar -> None
+
diff --git a/pretyping/instantiate.mli b/pretyping/instantiate.mli
new file mode 100644
index 00000000..44c4d579
--- /dev/null
+++ b/pretyping/instantiate.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  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: instantiate.mli,v 1.2.14.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Evd
+open Sign
+open Environ
+(*i*)
+
+(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+no body and [Not_found] if it does not exist in [sigma] *)
+
+exception NotInstantiatedEvar
+val existential_value : evar_map -> existential -> constr
+val existential_type : evar_map -> existential -> types
+val existential_opt_value : evar_map -> existential -> constr option
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
new file mode 100644
index 00000000..bdab3b5b
--- /dev/null
+++ b/pretyping/matching.ml
@@ -0,0 +1,254 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: matching.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Libnames
+open Nameops
+open Termops
+open Reductionops
+open Term
+open Rawterm
+open Environ
+open Pattern
+(*i*)
+
+(* Given a term with second-order variables in it,
+   represented by Meta's, and possibly applied using [SOAPP] to
+   terms, this function will perform second-order, binding-preserving,
+   matching, in the case where the pattern is a pattern in the sense
+   of Dale Miller.
+
+   ALGORITHM:
+
+   Given a pattern, we decompose it, flattening Cast's and apply's,
+   recursing on all operators, and pushing the name of the binder each
+   time we descend a binder.
+
+   When we reach a first-order variable, we ask that the corresponding
+   term's free-rels all be higher than the depth of the current stack.
+
+   When we reach a second-order application, we ask that the
+   intersection of the free-rels of the term and the current stack be
+   contained in the arguments of the application, and in that case, we
+   construct a LAMBDA with the names on the stack.
+
+ *)
+
+exception PatternMatchingFailure
+
+let constrain (n,m) sigma =
+  if List.mem_assoc n sigma then
+    if eq_constr m (List.assoc n sigma) then sigma
+    else raise PatternMatchingFailure
+  else 
+    (n,m)::sigma
+    
+let build_lambda toabstract stk (m : constr) = 
+  let rec buildrec m p_0 p_1 = match p_0,p_1 with 
+    | (_, []) -> m
+    | (n, (na,t)::tl) -> 
+	if List.mem n toabstract then
+          buildrec (mkLambda (na,t,m)) (n+1) tl
+        else 
+	  buildrec (lift (-1) m) (n+1) tl
+  in 
+  buildrec m 1 stk
+
+let memb_metavars m n =
+  match (m,n) with
+    | (None, _)     -> true
+    | (Some mvs, n) -> List.mem n mvs
+
+let eq_context ctxt1 ctxt2 = array_for_all2 eq_constr ctxt1 ctxt2
+
+let matches_core convert allow_partial_app pat c = 
+  let rec sorec stk sigma p t =
+    let cT = strip_outer_cast t in
+    match p,kind_of_term cT with
+      | PSoApp (n,args),m ->
+	  let relargs =
+	    List.map
+	      (function
+		 | PRel n -> n
+		 | _ -> error "Only bound indices are currently allowed in second order pattern matching")
+	      args in
+	  let frels = Intset.elements (free_rels cT) in
+	  if list_subset frels relargs then
+	    constrain (n,build_lambda relargs stk cT) sigma
+	  else
+	    raise PatternMatchingFailure
+
+      | PMeta (Some n), m ->
+	  let depth = List.length stk in
+	  let frels = Intset.elements (free_rels cT) in
+          if List.for_all (fun i -> i > depth) frels then
+	    constrain (n,lift (-depth) cT) sigma
+          else 
+	    raise PatternMatchingFailure
+
+      | PMeta None, m -> sigma
+
+      | PRef (VarRef v1), Var v2 when v1 = v2 -> sigma
+
+      | PVar v1, Var v2 when v1 = v2 -> sigma
+
+      | PRef ref, _ when constr_of_reference ref = cT -> sigma
+
+      | PRel n1, Rel n2 when n1 = n2 -> sigma
+
+      | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> sigma
+
+      | PSort (RType _), Sort (Type _) -> sigma
+
+      | PApp (PMeta (Some n),args1), App (c2,args2) when allow_partial_app ->
+          let p = Array.length args2 - Array.length args1 in
+          if p>=0 then
+            let args21, args22 = array_chop p args2 in
+            let sigma =
+	      let depth = List.length stk in
+              let c = mkApp(c2,args21) in
+	      let frels = Intset.elements (free_rels c) in
+              if List.for_all (fun i -> i > depth) frels then
+	        constrain (n,lift (-depth) c) sigma
+              else
+	        raise PatternMatchingFailure in
+            array_fold_left2 (sorec stk) sigma args1 args22
+          else raise PatternMatchingFailure
+
+      | PApp (c1,arg1), App (c2,arg2) ->
+        (try array_fold_left2 (sorec stk) (sorec stk sigma c1 c2) arg1 arg2
+         with Invalid_argument _ -> raise PatternMatchingFailure)
+
+      | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
+	  sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2
+
+      | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
+	  sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2
+
+      | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
+	  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 c = constr_of_reference ref in
+	  if is_conv env evars c cT then sigma
+	  else raise PatternMatchingFailure
+
+      | PCase (_,_,a1,br1), Case (_,_,a2,br2) ->
+	  (* On ne teste pas le prédicat *)
+          if (Array.length br1) = (Array.length br2) then
+  	    array_fold_left2 (sorec stk) (sorec stk sigma a1 a2) br1 br2
+          else
+            raise PatternMatchingFailure
+      (* À faire *)
+      |	PFix f0, Fix f1 when f0 = f1 -> sigma
+      |	PCoFix c0, CoFix c1 when c0 = c1 -> sigma
+      | _ -> raise PatternMatchingFailure
+
+  in 
+  Sort.list (fun (a,_) (b,_) -> a<b) (sorec [] [] pat c)
+
+let matches = matches_core None false
+
+let pmatches = matches_core None true
+
+(* To skip to the next occurrence *)
+exception NextOccurrence of int
+
+(* Tells if it is an authorized occurrence and if the instance is closed *)
+let authorized_occ nocc mres =
+  if not (List.for_all (fun (_,c) -> closed0 c) (fst mres)) then
+    raise PatternMatchingFailure;
+  if nocc = 0 then mres
+  else raise (NextOccurrence nocc)
+
+let special_meta = (-1)
+
+(* Tries to match a subterm of [c] with [pat] *)
+let rec sub_match nocc pat c =
+  match kind_of_term c with
+  | Cast (c1,c2) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,lc) = try_sub_match nocc pat [c1] in
+      (lm,mkCast (List.hd lc, c2))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in
+      (lm,mkCast (List.hd lc, c2)))
+  | Lambda (x,c1,c2) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,lc) = try_sub_match nocc pat [c1;c2] in
+      (lm,mkLambda (x,List.hd lc,List.nth lc 1))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in
+      (lm,mkLambda (x,List.hd lc,List.nth lc 1)))
+  | Prod (x,c1,c2) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,lc) = try_sub_match nocc pat [c1;c2] in
+      (lm,mkProd (x,List.hd lc,List.nth lc 1))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in
+      (lm,mkProd (x,List.hd lc,List.nth lc 1)))
+  | LetIn (x,c1,t2,c2) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in
+      (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;t2;c2] in
+      (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2)))
+  | App (c1,lc) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,le) = try_sub_match nocc pat (c1::(Array.to_list lc)) in
+      (lm,mkApp (List.hd le, Array.of_list (List.tl le)))
+    | NextOccurrence nocc ->
+      let (lm,le) = try_sub_match (nocc - 1) pat (c1::(Array.to_list lc)) in
+      (lm,mkApp (List.hd le, Array.of_list (List.tl le))))
+  | Case (ci,hd,c1,lc) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in
+      (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le)))
+    | NextOccurrence nocc ->
+      let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in
+      (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))))
+  | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _
+  | Rel _|Meta _|Var _|Sort _ ->
+    (try authorized_occ nocc ((matches pat c),mkMeta special_meta) with
+    | PatternMatchingFailure -> raise (NextOccurrence nocc)
+    | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1)))
+
+(* Tries [sub_match] for all terms in the list *)
+and try_sub_match nocc pat lc =
+  let rec try_sub_match_rec nocc pat lacc = function
+    | [] -> raise (NextOccurrence nocc)
+    | c::tl ->
+      (try 
+         let (lm,ce) = sub_match nocc pat c in
+         (lm,lacc@(ce::tl))
+       with
+      | NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in
+  try_sub_match_rec nocc pat [] lc
+
+let is_matching pat n =
+  try let _ = matches pat n in true
+  with PatternMatchingFailure -> false
+
+let matches_conv env sigma = matches_core (Some (env,sigma)) false
+
+let is_matching_conv env sigma pat n =
+  try let _ = matches_conv env sigma pat n in true
+  with PatternMatchingFailure -> false
+
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
new file mode 100644
index 00000000..808c46a4
--- /dev/null
+++ b/pretyping/matching.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  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: matching.mli,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Pattern
+open Termops
+(*i*)
+
+(*s This modules implements pattern-matching on terms *)
+
+exception PatternMatchingFailure
+
+val special_meta : metavariable
+
+(* [matches pat c] matches [c] against [pat] and returns the resulting
+   assignment of metavariables; it raises [PatternMatchingFailure] if
+   not matchable; bindings are given in increasing order based on the
+   numbers given in the pattern *)
+val matches : constr_pattern -> constr -> patvar_map
+
+(* [is_matching pat c] just tells if [c] matches against [pat] *)
+
+val is_matching : constr_pattern -> constr -> bool
+
+(* [matches_conv env sigma] matches up to conversion in environment
+   [(env,sigma)] when constants in pattern are concerned; it raises
+   [PatternMatchingFailure] if not matchable; bindings are given in
+   increasing order based on the numbers given in the pattern *)
+
+val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
+
+(* To skip to the next occurrence *)
+exception NextOccurrence of int
+
+(* Tries to match a _closed_ subterm of [c] with [pat] *)
+val sub_match : int -> constr_pattern -> constr -> patvar_map * constr
+
+(* [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
+   up to conversion for constants in patterns *)
+
+val is_matching_conv :
+  env -> Evd.evar_map -> constr_pattern -> constr -> bool
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
new file mode 100644
index 00000000..80ab1b6e
--- /dev/null
+++ b/pretyping/pattern.ml
@@ -0,0 +1,287 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: pattern.ml,v 1.24.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Rawterm
+open Environ
+open Nametab
+open Pp
+
+(* Metavariables *)
+
+type patvar_map = (patvar * constr) list
+let patvar_of_int n =
+  let p = if !Options.v7 & not (Options.do_translate ()) then "?" else "X"
+  in
+  Names.id_of_string (p ^ string_of_int n)
+let pr_patvar = pr_id
+
+let patvar_of_int_v7 n = Names.id_of_string ("?" ^ string_of_int n)
+
+(* Patterns *)
+
+type constr_pattern =
+  | PRef of global_reference
+  | PVar of identifier
+  | PEvar of existential_key * constr_pattern array
+  | PRel of int
+  | PApp of constr_pattern * constr_pattern array
+  | PSoApp of patvar * constr_pattern list
+  | PLambda of name * constr_pattern * constr_pattern
+  | PProd of name * constr_pattern * constr_pattern
+  | PLetIn of name * constr_pattern * constr_pattern
+  | PSort of rawsort
+  | PMeta of patvar option
+  | PCase of (inductive option * case_style)
+      * constr_pattern option * constr_pattern * constr_pattern array
+  | PFix of fixpoint
+  | PCoFix of cofixpoint
+
+let rec occur_meta_pattern = function
+  | PApp (f,args) ->
+      (occur_meta_pattern f) or (array_exists occur_meta_pattern args)
+  | PLambda (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
+  | PProd (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
+  | PLetIn (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
+  | PCase(_,None,c,br)   ->
+      (occur_meta_pattern c) or (array_exists occur_meta_pattern br)
+  | PCase(_,Some p,c,br) ->
+      (occur_meta_pattern p) or
+      (occur_meta_pattern c) or (array_exists occur_meta_pattern br)
+  | PMeta _ | PSoApp _ -> true
+  | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false
+
+let rec subst_pattern subst pat = match pat with
+  | PRef ref ->
+      let ref' = subst_global subst ref in
+	if ref' == ref then pat else 
+	  PRef ref'
+  | PVar _ 
+  | PEvar _
+  | PRel _ -> pat
+  | PApp (f,args) ->
+      let f' = subst_pattern subst f in 
+      let args' = array_smartmap (subst_pattern subst) args in
+	if f' == f && args' == args then pat else
+	  PApp (f',args')
+  | PSoApp (i,args) ->
+      let args' = list_smartmap (subst_pattern subst) args in
+	if args' == args then pat else
+	  PSoApp (i,args')
+  | PLambda (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PLambda (name,c1',c2')
+  | PProd (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PProd (name,c1',c2')
+  | PLetIn (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PLetIn (name,c1',c2')
+  | PSort _ 
+  | PMeta _ -> pat
+  | PCase (cs,typ, c, branches) -> 
+      let typ' = option_smartmap (subst_pattern subst) typ in 
+      let c' = subst_pattern subst c in
+      let branches' = array_smartmap (subst_pattern subst) branches in
+	if typ' == typ && c' == c && branches' == branches then pat else
+	  PCase(cs,typ', c', branches') 
+  | PFix fixpoint ->
+      let cstr = mkFix fixpoint in
+      let fixpoint' = destFix (subst_mps subst cstr) in
+	if fixpoint' == fixpoint then pat else
+	  PFix fixpoint'
+  | PCoFix cofixpoint ->
+      let cstr = mkCoFix cofixpoint in
+      let cofixpoint' = destCoFix (subst_mps subst cstr) in
+	if cofixpoint' == cofixpoint then pat else
+	  PCoFix cofixpoint'
+
+type constr_label =
+  | ConstNode of constant
+  | IndNode of inductive
+  | CstrNode of constructor
+  | VarNode of identifier
+
+exception BoundPattern;;
+
+let label_of_ref = function
+  | ConstRef sp     -> ConstNode sp
+  | IndRef sp       -> IndNode sp
+  | ConstructRef sp -> CstrNode sp
+  | VarRef id       -> VarNode id
+
+let ref_of_label = function
+  | ConstNode sp     -> ConstRef sp
+  | IndNode sp       -> IndRef sp
+  | CstrNode sp      -> ConstructRef sp
+  | VarNode id       -> VarRef id
+
+let subst_label subst cstl = 
+  let ref = ref_of_label cstl in
+  let ref' = subst_global subst ref in
+    if ref' == ref then cstl else
+      label_of_ref ref'
+      
+  
+let rec head_pattern_bound t =
+  match t with
+    | PProd (_,_,b)  -> head_pattern_bound b 
+    | PLetIn (_,_,b) -> head_pattern_bound b 
+    | PApp (c,args)  -> head_pattern_bound c
+    | PCase (_,p,c,br) -> head_pattern_bound c
+    | PRef r         -> label_of_ref r
+    | PVar id        -> VarNode id
+    | PEvar _ | PRel _ | PMeta _ | PSoApp _  | PSort _ | PFix _
+	-> raise BoundPattern
+    (* Perhaps they were arguments, but we don't beta-reduce *)
+    | PLambda _ -> raise BoundPattern
+    | PCoFix _ -> anomaly "head_pattern_bound: not a type"
+
+let head_of_constr_reference c = match kind_of_term c with
+  | Const sp -> ConstNode sp
+  | Construct sp -> CstrNode sp
+  | Ind sp -> IndNode sp
+  | Var id -> VarNode id
+  | _ -> anomaly "Not a rigid reference"
+
+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)))
+    | Var id -> PVar id
+    | Sort (Prop c) -> PSort (RProp c)
+    | Sort (Type _) -> PSort (RType None)
+    | Cast (c,_)      -> pattern_of_constr c
+    | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
+    | Prod (na,c,b)   -> PProd (na,pattern_of_constr c,pattern_of_constr b)
+    | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b)
+    | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a)
+    | Const sp         -> PRef (ConstRef sp)
+    | Ind sp        -> PRef (IndRef sp)
+    | Construct sp -> PRef (ConstructRef sp)
+    | Evar (n,ctxt) -> PEvar (n,Array.map pattern_of_constr ctxt)
+    | Case (ci,p,a,br) ->
+	PCase ((Some ci.ci_ind,ci.ci_pp_info.style),
+	       Some (pattern_of_constr p),pattern_of_constr a,
+	       Array.map pattern_of_constr br)
+    | Fix f -> PFix f
+    | CoFix _ ->
+	error "pattern_of_constr: (co)fix currently not supported"
+
+(* To process patterns, we need a translation without typing at all. *)
+
+let rec inst lvar = function
+  | PVar id as x -> (try List.assoc id lvar with Not_found -> x)
+  | PApp (p,pl) -> PApp (inst lvar p, Array.map (inst lvar) pl)
+  | PSoApp (n,pl) -> PSoApp (n, List.map (inst lvar) pl)
+  | PLambda (n,a,b) -> PLambda (n,inst lvar a,inst lvar b)
+  | PProd (n,a,b) -> PProd (n,inst lvar a,inst lvar b)
+  | PLetIn (n,a,b) -> PLetIn (n,inst lvar a,inst lvar b)
+  | PCase (ci,po,p,pl) ->
+      PCase (ci,option_app (inst lvar) po,inst lvar p,Array.map (inst lvar) pl)
+  (* Non recursive *)
+  | (PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _ as x) -> x 
+  (* Bound to terms *)
+  | (PFix _ | PCoFix _ as r) ->
+      error ("Not instantiable pattern")
+
+let instantiate_pattern = inst
+
+let rec pat_of_raw metas vars = function
+  | RVar (_,id) ->
+      (try PRel (list_index (Name id) vars)
+       with Not_found -> PVar id)
+  | RPatVar (_,(false,n)) ->
+      metas := n::!metas; PMeta (Some n)
+  | RRef (_,r) ->
+      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)
+  | 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) ->
+      PLambda (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RProd (_,na,c1,c2) ->
+      PProd (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RLetIn (_,na,c1,c2) ->
+      PLetIn (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RSort (_,s) ->
+      PSort s
+  | RHole _ ->
+      PMeta None
+  | RCast (_,c,t) ->
+      Options.if_verbose
+        Pp.warning "Cast not taken into account in constr pattern";
+      pat_of_raw metas vars c
+  | ROrderedCase (_,st,po,c,br,_) ->
+      PCase ((None,st),option_app (pat_of_raw metas vars) po,
+             pat_of_raw metas vars c,
+             Array.map (pat_of_raw metas vars) br)
+  | RIf (_,c,(_,None),b1,b2) ->
+      PCase ((None,IfStyle),None, pat_of_raw metas vars c,
+             [|pat_of_raw metas vars b1; pat_of_raw metas vars b2|])
+  | RCases (loc,(po,_),[c,_],brs) ->
+      let sp =
+	match brs with
+	  | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
+	  | _ -> None in
+      (* When po disappears: switch to rtn type *)
+      PCase ((sp,Term.RegularStyle),option_app (pat_of_raw metas vars) po,
+             pat_of_raw metas vars c,
+             Array.init (List.length brs)
+	       (pat_of_raw_branch loc metas vars sp brs))
+  | r ->
+      let loc = loc_of_rawconstr r in
+      user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern")
+
+and pat_of_raw_branch loc metas vars ind brs i =
+  let bri = List.filter
+    (function
+        (_,_,[PatCstr(_,c,lv,_)],_) -> snd c = i+1
+      | (loc,_,_,_) ->
+          user_err_loc (loc,"pattern_of_rawconstr",
+                        Pp.str "Not supported pattern")) brs in
+  match bri with
+      [(_,_,[PatCstr(_,(indsp,_),lv,_)],br)] ->
+	if ind <> None & ind <> Some indsp then
+          user_err_loc (loc,"pattern_of_rawconstr",
+            Pp.str "All constructors must be in the same inductive type");
+        let lna =
+          List.map
+            (function PatVar(_,na) -> na
+              | PatCstr(loc,_,_,_) ->
+                  user_err_loc (loc,"pattern_of_rawconstr",
+                                Pp.str "Not supported pattern")) lv in
+        let vars' = List.rev lna @ vars in 
+        List.fold_right (fun na b -> PLambda(na,PMeta None,b)) lna
+          (pat_of_raw metas vars' br)
+    | _ -> user_err_loc (loc,"pattern_of_rawconstr",
+                         str "No unique branch for " ++ int (i+1) ++
+                         str"-th constructor")
+
+let pattern_of_rawconstr c =
+  let metas = ref [] in
+  let p = pat_of_raw metas [] c in
+  (!metas,p)
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
new file mode 100644
index 00000000..cf0d4528
--- /dev/null
+++ b/pretyping/pattern.mli
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  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: pattern.mli,v 1.17.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Sign
+open Term
+open Environ
+open Libnames
+open Nametab
+open Rawterm
+(*i*)
+
+(* Pattern variables *)
+
+type patvar_map = (patvar * constr) list
+val pr_patvar : patvar -> std_ppcmds
+
+(* Only for v7 parsing/printing *)
+val patvar_of_int : int -> patvar
+val patvar_of_int_v7 : int -> patvar
+
+(* Patterns *)
+
+type constr_pattern =
+  | PRef of global_reference
+  | PVar of identifier
+  | PEvar of existential_key * constr_pattern array
+  | PRel of int
+  | PApp of constr_pattern * constr_pattern array
+  | PSoApp of patvar * constr_pattern list
+  | PLambda of name * constr_pattern * constr_pattern
+  | PProd of name * constr_pattern * constr_pattern
+  | PLetIn of name * constr_pattern * constr_pattern
+  | PSort of rawsort
+  | PMeta of patvar option
+  | PCase of (inductive option * case_style)
+      * constr_pattern option * constr_pattern * constr_pattern array
+  | PFix of fixpoint
+  | PCoFix of cofixpoint
+
+val occur_meta_pattern : constr_pattern -> bool
+
+val subst_pattern : substitution -> constr_pattern -> constr_pattern
+
+type constr_label =
+  | ConstNode of constant
+  | IndNode of inductive
+  | CstrNode of constructor
+  | VarNode of identifier
+
+val label_of_ref : global_reference -> constr_label
+
+val subst_label : substitution -> constr_label -> constr_label
+
+exception BoundPattern
+
+(* [head_pattern_bound t] extracts the head variable/constant of the
+   type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
+   if [t] is an abstraction *)
+
+val head_pattern_bound : constr_pattern -> constr_label
+
+(* [head_of_constr_reference c] assumes [r] denotes a reference and
+   returns its label; raises an anomaly otherwise *)
+
+val head_of_constr_reference : Term.constr -> constr_label
+
+(* [pattern_of_constr c] translates a term [c] with metavariables into
+   a pattern; currently, no destructor (Cases, Fix, Cofix) and no
+   existential variable are allowed in [c] *)
+
+val pattern_of_constr : constr -> constr_pattern
+
+(* [pattern_of_rawconstr l c] translates a term [c] with metavariables into
+   a pattern; variables bound in [l] are replaced by the pattern to which they
+    are bound *)
+
+val pattern_of_rawconstr : rawconstr -> 
+      patvar list * constr_pattern
+
+val instantiate_pattern :
+  (identifier * constr_pattern) list -> constr_pattern -> constr_pattern
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
new file mode 100644
index 00000000..fee1522f
--- /dev/null
+++ b/pretyping/pretype_errors.ml
@@ -0,0 +1,164 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: pretype_errors.ml,v 1.25.2.2 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Stdpp
+open Names
+open Sign
+open Term
+open Termops
+open Environ
+open Type_errors
+open Rawterm
+open Inductiveops
+
+type pretype_error =
+  (* Old Case *)
+  | CantFindCaseType of constr
+  (* Unification *)
+  | OccurCheck of existential_key * constr
+  | NotClean of existential_key * constr * hole_kind
+  | UnsolvableImplicit of hole_kind
+  (* Pretyping *)
+  | VarNotFound of identifier
+  | UnexpectedType of constr * constr
+  | NotProduct of constr
+
+exception PretypeError of env * pretype_error
+
+let nf_evar = Reductionops.nf_evar
+let j_nf_evar sigma j = 
+  { uj_val = nf_evar sigma j.uj_val;
+    uj_type = nf_evar sigma j.uj_type }
+let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
+let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
+let tj_nf_evar sigma {utj_val=v;utj_type=t} =
+  {utj_val=type_app (nf_evar sigma) v;utj_type=t}
+
+let env_ise sigma env =
+  let sign = named_context env in
+  let ctxt = rel_context env in
+  let env0 = reset_with_named_context sign env in
+  Sign.fold_rel_context
+    (fun (na,b,ty) e ->
+      push_rel
+        (na, option_app (nf_evar sigma) b, nf_evar sigma ty)
+        e)
+    ctxt
+    ~init:env0
+
+(* This simplify the typing context of Cases clauses *)
+(* hope it does not disturb other typing contexts *)
+let contract env lc =
+  let l = ref [] in
+  let contract_context (na,c,t) env =
+    match c with
+      | Some c' when isRel c' ->
+	  l := (substl !l c') :: !l;
+	  env
+      | _ -> 
+	  let t' = substl !l t in
+	  let c' = option_app (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
+  let env = process_rel_context contract_context env in
+  (env, List.map (substl !l) lc)
+
+let contract2 env a b = match contract env [a;b] with
+  | env, [a;b] -> env,a,b | _ -> assert false
+
+let contract3 env a b c = match contract env [a;b;c] with
+  | env, [a;b;c] -> env,a,b,c | _ -> assert false
+
+let raise_pretype_error (loc,ctx,sigma,te) =
+  Stdpp.raise_with_loc loc (PretypeError(env_ise sigma ctx,te))
+
+let raise_located_type_error (loc,ctx,sigma,te) =
+  Stdpp.raise_with_loc loc (TypeError(env_ise sigma ctx,te))
+
+
+let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty =
+  let env, c, actty, expty = contract3 env c actty expty in
+  let j = j_nf_evar sigma {uj_val=c;uj_type=actty} in
+  raise_located_type_error
+    (loc, env, sigma, ActualType (j, nf_evar sigma expty))
+
+let error_cant_apply_not_functional_loc loc env sigma rator randl =
+  let ja = Array.of_list (jl_nf_evar sigma randl) in
+  raise_located_type_error
+    (loc, env, sigma,
+    CantApplyNonFunctional (j_nf_evar sigma rator, ja))
+
+let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl =
+  let ja = Array.of_list (jl_nf_evar sigma randl) in
+  raise_located_type_error
+    (loc, env, sigma,
+     CantApplyBadType
+       ((n,nf_evar sigma c, nf_evar sigma t),
+        j_nf_evar sigma rator, ja))
+
+let error_ill_formed_branch_loc loc env sigma c i actty expty =
+  let simp t = Reduction.nf_betaiota (nf_evar sigma t) in
+  raise_located_type_error
+    (loc, env, sigma,
+     IllFormedBranch (nf_evar sigma c,i,simp actty, simp expty))
+
+let error_number_branches_loc loc env sigma cj expn =
+  raise_located_type_error
+    (loc, env, sigma,
+     NumberBranches (j_nf_evar sigma cj, expn))
+
+let error_case_not_inductive_loc loc env sigma cj =
+  raise_located_type_error
+    (loc, env, sigma, CaseNotInductive (j_nf_evar sigma cj))
+
+let error_ill_typed_rec_body_loc loc env sigma i na jl tys =
+  raise_located_type_error
+    (loc, env, sigma,
+     IllTypedRecBody (i,na,jv_nf_evar sigma jl,
+                      Array.map (nf_evar sigma) tys))
+
+(*s Implicit arguments synthesis errors. It is hard to find
+    a precise location. *)
+
+let error_occur_check env sigma ev c =
+  let c = nf_evar sigma c in
+  raise (PretypeError (env_ise sigma env, OccurCheck (ev,c)))
+
+let error_not_clean env sigma ev c (loc,k) =
+  let c = nf_evar sigma c in
+  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))
+
+(*s Ml Case errors *)
+
+let error_cant_find_case_type_loc loc env sigma expr =
+  raise_pretype_error
+    (loc, env, sigma, CantFindCaseType (nf_evar sigma expr))
+
+(*s Pretyping errors *)
+
+let error_unexpected_type_loc loc env sigma actty expty =
+  let env, actty, expty = contract2 env actty expty in
+  raise_pretype_error
+    (loc, env, sigma,
+     UnexpectedType (nf_evar sigma actty, nf_evar sigma expty))
+
+let error_not_product_loc loc env sigma c =
+  raise_pretype_error (loc, env, sigma, NotProduct (nf_evar sigma c))
+
+(*s Error in conversion from AST to rawterms *)
+
+let error_var_not_found_loc loc s =
+  raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s)
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
new file mode 100644
index 00000000..ebeff99d
--- /dev/null
+++ b/pretyping/pretype_errors.mli
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  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: pretype_errors.mli,v 1.25.2.3 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Rawterm
+open Inductiveops
+(*i*)
+
+(*s The type of errors raised by the pretyper *)
+
+type pretype_error =
+  (* Old Case *)
+  | CantFindCaseType of constr
+  (* Unification *)
+  | OccurCheck of existential_key * constr
+  | NotClean of existential_key * constr * hole_kind
+  | UnsolvableImplicit of hole_kind
+  (* Pretyping *)
+  | VarNotFound of identifier
+  | UnexpectedType of constr * constr
+  | NotProduct of constr
+
+exception PretypeError of env * pretype_error
+
+(* Presenting terms without solved evars *)
+val nf_evar :  Evd.evar_map -> constr -> constr
+val j_nf_evar :  Evd.evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar :
+   Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar :
+   Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar :
+   Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+
+(* Raising errors *)
+val error_actual_type_loc :
+  loc -> env ->  Evd.evar_map -> unsafe_judgment -> constr -> 'b
+
+val error_cant_apply_not_functional_loc : 
+  loc -> env ->  Evd.evar_map ->
+      unsafe_judgment -> unsafe_judgment list -> 'b
+
+val error_cant_apply_bad_type_loc : 
+  loc -> env ->  Evd.evar_map -> int * constr * constr -> 
+      unsafe_judgment -> unsafe_judgment list -> 'b
+
+val error_case_not_inductive_loc :
+  loc -> env ->  Evd.evar_map -> unsafe_judgment -> 'b
+
+val error_ill_formed_branch_loc : 
+  loc -> env ->  Evd.evar_map ->
+      constr -> int -> constr -> constr -> 'b
+
+val error_number_branches_loc : 
+  loc -> env ->  Evd.evar_map ->
+      unsafe_judgment -> int -> 'b
+
+val error_ill_typed_rec_body_loc :
+  loc -> env ->  Evd.evar_map ->
+      int -> name array -> unsafe_judgment array -> types array -> 'b
+
+(*s Implicit arguments synthesis errors *)
+
+val error_occur_check : env ->  Evd.evar_map -> existential_key -> constr -> 'b
+
+val error_not_clean :
+  env ->  Evd.evar_map -> existential_key -> constr -> loc * hole_kind -> 'b
+
+val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> hole_kind -> 'b
+
+(*s Ml Case errors *)
+
+val error_cant_find_case_type_loc :
+  loc -> env ->  Evd.evar_map -> constr -> 'b
+
+(*s Pretyping errors *)
+
+val error_unexpected_type_loc :
+  loc -> env ->  Evd.evar_map -> constr -> constr -> 'b
+
+val error_not_product_loc :
+  loc -> env ->  Evd.evar_map -> constr -> 'b
+
+(*s Error in conversion from AST to rawterms *)
+
+val error_var_not_found_loc : loc -> identifier -> 'b
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
new file mode 100644
index 00000000..36df9c8a
--- /dev/null
+++ b/pretyping/pretyping.ml
@@ -0,0 +1,1024 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: pretyping.ml,v 1.123.2.3 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops 
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Coercion
+open Pattern
+open Dyn
+
+
+(************************************************************************)
+(* This concerns Cases *)
+open Declarations
+open Inductive
+open Inductiveops
+open Instantiate
+
+let lift_context n l = 
+  let k = List.length l in 
+  list_map_i (fun i (name,c) -> (name,liftn n (k-i) c)) 0 l
+
+let transform_rec loc env sigma (pj,c,lf) indt = 
+  let p = pj.uj_val in
+  let (indf,realargs) = dest_ind_type indt in
+  let (ind,params) = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let recargs = mip.mind_recargs in
+  let mI = mkInd ind in
+  let ci = make_default_case_info env (if Options.do_translate() then RegularStyle else MatchStyle) ind in
+  let nconstr = Array.length mip.mind_consnames in
+  if Array.length lf <> nconstr then 
+    (let cj = {uj_val=c; uj_type=mkAppliedInd indt} in
+     error_number_branches_loc loc env sigma cj nconstr);
+  let tyi = snd ind in
+  if mis_is_recursive_subset [tyi] recargs then
+    let dep =
+      is_dependent_elimination env (nf_evar sigma pj.uj_type) indf in 
+    let init_depFvec i = if i = tyi then Some(dep,mkRel 1) else None in
+    let depFvec = Array.init mib.mind_ntypes init_depFvec in
+    (* build now the fixpoint *)
+    let lnames,_ = get_arity env indf in
+    let nar = List.length lnames in
+    let nparams = mip.mind_nparams in
+    let constrs = get_constructors env (lift_inductive_family (nar+2) indf) in
+    let branches = 
+      array_map3
+	(fun f t reca -> 
+	   whd_beta
+             (Indrec.make_rec_branch_arg env sigma
+                (nparams,depFvec,nar+1)
+                f t reca))
+        (Array.map (lift (nar+2)) lf) constrs (dest_subterms recargs) 
+    in 
+    let deffix = 
+      it_mkLambda_or_LetIn_name env
+	(lambda_create env
+	   (applist (mI,List.append (List.map (lift (nar+1)) params)
+                       (extended_rel_list 0 lnames)),
+            mkCase (ci, lift (nar+2) p, mkRel 1, branches)))
+        (lift_rel_context 1 lnames) 
+    in
+    if noccurn 1 deffix then 
+      whd_beta (applist (pop deffix,realargs@[c]))
+    else
+      let ind = applist (mI,(List.append 
+			     (List.map (lift nar) params)
+			     (extended_rel_list 0 lnames))) in
+      let typPfix = 
+	it_mkProd_or_LetIn_name env
+	  (prod_create env 
+	     (ind,
+	      (if dep then
+		 let ext_lnames = (Anonymous,None,ind)::lnames in
+		 let args = extended_rel_list 0 ext_lnames in
+		 whd_beta (applist (lift (nar+1) p, args))
+	       else
+		 let args = extended_rel_list 1 lnames in
+		 whd_beta (applist (lift (nar+1) p, args)))))
+          lnames in
+      let fix =
+        mkFix (([|nar|],0),
+	       ([|Name(id_of_string "F")|],[|typPfix|],[|deffix|])) in
+      applist (fix,realargs@[c])
+  else
+    mkCase (ci, p, c, lf)
+
+(************************************************************************)
+
+(* To embed constr in rawconstr *)
+let ((constr_in : constr -> Dyn.t),
+     (constr_out : Dyn.t -> constr)) = create "constr"
+
+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 lt = Array.length vdefj in 
+    if Array.length lar = lt then 
+      for i = 0 to lt-1 do 
+        if not (the_conv_x_leq env isevars
+		  (vdefj.(i)).uj_type
+		  (lift lt lar.(i))) then
+          error_ill_typed_rec_body_loc loc env (evars_of isevars)
+            i lna vdefj lar
+      done
+
+let check_branches_message loc env isevars c (explft,lft) = 
+  for i = 0 to Array.length explft - 1 do
+    if not (the_conv_x_leq env isevars lft.(i) explft.(i)) then 
+      let sigma = evars_of isevars 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
+   | None -> j
+   | Some typ -> inh_conv_coerce_to loc env isevars j typ
+
+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)
+*)
+
+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 pretype_id loc env (lvar,unbndltacvars) id =
+  let id = strip_meta id in (* May happen in tactics defined by Grammar *)
+  try
+    List.assoc id lvar
+  with Not_found ->
+  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
+    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 (string_of_id id ^ " ist not 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 *)
+
+let make_dep_of_undep env (IndType (indf,realargs)) pj =
+  let n = List.length realargs in
+  let rec decomp n p =
+    if n=0 then p else
+      match kind_of_term p with
+	| Lambda (_,_,c) -> decomp (n-1) c
+	| _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
+  in
+  let sign,s = decompose_prod_n n pj.uj_type in
+  let ind = build_dependent_inductive env indf in
+  let s' = mkProd (Anonymous, ind, s) in
+  let ccl = lift 1 (decomp n pj.uj_val) in
+  let ccl' = mkLambda (Anonymous, ind, ccl) in
+  {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
+
+(*************************************************************************)
+(* Main pretyping function                                               *)
+
+let pretype_ref isevars env ref = 
+  let c = constr_of_reference ref in
+  make_judge c (Retyping.get_type_of env Evd.empty c)
+
+let pretype_sort = function
+  | 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 *)
+(* the type constraint tycon *)
+let rec pretype tycon env isevars lvar = function
+
+  | RRef (loc,ref) ->
+      inh_conv_coerce_to_tycon loc env isevars
+	(pretype_ref isevars env ref)
+	tycon
+
+  | RVar (loc, id) ->
+      inh_conv_coerce_to_tycon loc env isevars
+	(pretype_id loc env lvar id)
+	tycon
+
+  | REvar (loc, ev, 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 = (Evd.map (evars_of isevars) ev).evar_hyps 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
+
+  | RPatVar (loc,(someta,n)) -> 
+      anomaly "Found a pattern variable in a rawterm to type"
+	   
+  | RHole (loc,k) ->
+      if !compter then nbimpl:=!nbimpl+1;
+      (match tycon with
+	 | Some ty ->
+	     { uj_val = new_isevar isevars env (loc,k) ty; uj_type = ty }
+	 | None -> error_unsolvable_implicit loc env (evars_of isevars) k)
+
+  | 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
+            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
+            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)
+          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
+      let nbfix = Array.length lar in
+      let names = Array.map (fun id -> Name id) names in
+      (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+      let newenv = push_rec_types (names,ftys,[||]) env in
+      let vdefj =
+	array_map2_i 
+	  (fun i ctxt def ->
+            (* we lift nbfix times the type in tycon, because of
+	     * the nbfix variables pushed to newenv *)
+            let (ctxt,ty) =
+              decompose_prod_n_assum (rel_context_length ctxt)
+                (lift nbfix ftys.(i)) in
+            let nenv = push_rel_context ctxt newenv in
+            let j = pretype (mk_tycon ty) nenv isevars 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;
+      let fixj =
+	match fixkind with
+	  | RFix (vn,i as vni) ->
+	      let fix = (vni,(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 -> 
+	      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
+
+  | RSort (loc,s) ->
+      inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+
+  | RApp (loc,f,args) -> 
+      let fj = pretype empty_tycon env isevars 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 = inh_app_fun env isevars resj in
+            let resty =
+              whd_betadeltaiota env (evars_of isevars) 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 newresj =
+      		    { uj_val = applist (j_val resj, [j_val hj]);
+		      uj_type = subst1 hj.uj_val c2 } in
+		  apply_rec env (n+1) newresj rest
+
+	      | _ ->
+		  let hj = pretype empty_tycon env isevars lvar c in
+		  error_cant_apply_not_functional_loc 
+		    (join_loc floc argloc) env (evars_of isevars)
+	      	    resj [hj]
+
+      in let resj = apply_rec env 1 fj args in
+      (*
+	let apply_one_arg (floc,tycon,jl) c =
+	let (dom,rng) = split_tycon floc env isevars tycon in
+	let cj = pretype dom env isevars lvar c in
+	let rng_tycon = option_app (subst1 cj.uj_val) rng in
+	let argloc = loc_of_rawconstr c in
+	(join_loc floc argloc,rng_tycon,(argloc,cj)::jl)  in
+	let _,_,jl =
+	List.fold_left apply_one_arg (floc,mk_tycon j.uj_type,[]) args in
+	let jl = List.rev jl in
+	let resj = inh_apply_rel_list loc env isevars jl (floc,j) tycon in
+      *)
+      inh_conv_coerce_to_tycon loc env isevars resj tycon
+
+  | RLambda(loc,name,c1,c2)      ->
+      let (name',dom,rng) = split_tycon loc env isevars tycon in
+      let dom_valcon = valcon_of_tycon dom in
+      let j = pretype_type dom_valcon env isevars 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'
+
+  | RProd(loc,name,c1,c2)        ->
+      let j = pretype_type empty_valcon env isevars 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 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
+	
+  | RLetIn(loc,name,c1,c2)      ->
+      let j = pretype empty_tycon env isevars lvar c1 in
+      let t = Evarutil.refresh_universes j.uj_type in
+      let var = (name,Some j.uj_val,t) in
+        let tycon = option_app (lift 1) tycon in
+      let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+      { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
+	uj_type = type_app (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 (IndType (indf,realargs) as indt) = 
+	try find_rectype env (evars_of isevars) 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
+      let cstrs = get_constructors env indf in
+      if Array.length cstrs <> 1 then
+        user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
+      let cs = cstrs.(0) in
+      if List.length nal <> cs.cs_nargs then
+        user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
+      let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
+        (List.rev nal) cs.cs_args in
+      let env_f = push_rels fsign env in
+      (* Make dependencies from arity signature impossible *)
+      let arsgn,_ = get_arity env indf in
+      let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
+      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let nar = List.length arsgn in
+      (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 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 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
+	       mkCase (ci, p, cj.uj_val,[|f|]) in 
+             let cs = build_dependent_constructor cs in
+	     { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+	 | None -> 
+             let tycon = option_app (lift cs.cs_nargs) tycon in
+	     let fj = pretype tycon env_f isevars lvar d in
+	     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+	     let ccl = nf_evar (evars_of isevars) 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) 
+                   cj.uj_val 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
+	       mkCase (ci, p, cj.uj_val,[|f|] ) 
+	     in
+	     { uj_val = v; uj_type = ccl })
+
+  (* Special Case for let constructions to avoid exponential behavior *)      
+  | ROrderedCase (loc,st,po,c,[|f|],xx) when st <> MatchStyle ->
+      let cj = pretype empty_tycon env isevars lvar c in
+      let (IndType (indf,realargs) as indt) = 
+	try find_rectype env (evars_of isevars) 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
+      let j = match po with
+	 | Some p ->
+             let pj = pretype empty_tycon env isevars lvar p in
+             let dep = is_dependent_elimination env pj.uj_type indf in
+             let ar =
+               arity_of_case_predicate env indf dep (Type (new_univ())) in
+             let _ = the_conv_x_leq env isevars pj.uj_type ar in
+	     let pj = j_nf_evar (evars_of isevars) pj in
+	     let pj = if dep then pj else make_dep_of_undep env indt pj in
+	     let (bty,rsty) = 
+	       Indrec.type_rec_branches 
+		 false env (evars_of isevars) indt pj.uj_val cj.uj_val 
+	     in
+	     if Array.length bty <> 1 then
+	       error_number_branches_loc 
+		 loc env (evars_of isevars) cj (Array.length bty);
+	     let fj = 
+	       let tyc = bty.(0) in 
+	       pretype (mk_tycon tyc) env isevars lvar f 
+	     in
+	     let fv = j_val fj in
+	     let ft = fj.uj_type in
+	     check_branches_message loc env isevars cj.uj_val (bty,[|ft|]);
+	     let v =
+	       let mis,_ = dest_ind_family indf in
+	       let ci = make_default_case_info env st mis in
+	       mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|])
+	     in 
+	     { uj_val = v;  uj_type = rsty }
+
+	 | None -> 
+             (* get type information from type of branches *)
+	     let expbr = Cases.branch_scheme env isevars false indf in
+	     if Array.length expbr <> 1 then
+	       error_number_branches_loc loc env (evars_of isevars) 
+		 cj (Array.length expbr);
+             let expti = expbr.(0) in
+	     let fj = pretype (mk_tycon expti) env isevars lvar f in
+	     let use_constraint () =
+               (* get type information from constraint *)
+               (* warning: if the constraint comes from an evar type, it *)
+               (* may be Type while Prop or Set would be expected *)
+	       match tycon with
+		 | Some pred ->
+		     let arsgn = make_arity_signature env true indf in
+                     let pred = lift (List.length arsgn) pred in
+  		     let pred = 
+                       it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
+			 arsgn in
+                     false, pred
+	         | None ->
+                     let sigma = evars_of isevars in
+                     error_cant_find_case_type_loc loc env sigma cj.uj_val
+	     in
+             let ok, p =
+	       try
+		 let pred = 
+		   Cases.pred_case_ml 
+		     env (evars_of isevars) false indt (0,fj.uj_type) 
+		 in 
+		 if has_undefined_isevars isevars pred then
+		   use_constraint ()
+		 else
+		   true, pred
+	       with Cases.NotInferable _ ->
+		 use_constraint ()
+	     in 
+	     let p = nf_evar (evars_of isevars) p in
+	     let (bty,rsty) =
+	       Indrec.type_rec_branches
+		 false env (evars_of isevars) indt p cj.uj_val 
+	     in
+	     let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
+	     let fj = 
+	       if ok then fj 
+	       else pretype (mk_tycon bty.(0)) env isevars lvar f 
+	     in
+	     let fv = fj.uj_val in
+	     let ft = fj.uj_type in
+	     let v =
+	       let mis,_ = dest_ind_family indf in
+	       let ci = make_default_case_info env st mis in
+	       mkCase (ci, (nf_betaiota p), cj.uj_val,[|fv|] ) 
+	     in
+	     { uj_val = v; uj_type = rsty } in
+
+      (* Build the LetTuple form for v8 *)
+      let c =
+        let (ind,params) = dest_ind_family indf in
+        let rtntypopt, indnalopt = match po with
+          | None -> None, (Anonymous,None)
+          | Some p ->
+              let pj = pretype empty_tycon env isevars lvar p in
+              let dep = is_dependent_elimination env pj.uj_type indf in
+              let rec decomp_lam_force n avoid l p =
+                (* avoid is not exhaustive ! *)
+                if n = 0 then (List.rev l,p,avoid) else
+                  match p with
+                    | 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
+                    | _ ->
+                        let x = Nameops.next_ident_away (id_of_string "x") avoid in
+                        decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+                          (* eta-expansion *)
+                          (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
+              let (nal,p,avoid) = 
+                decomp_lam_force (List.length realargs) [] [] p in
+              let na,rtntyp,_ = 
+                if dep then decomp_lam_force 1 avoid [] p
+                else [Anonymous],p,[] in
+              let intyp =
+                if List.for_all
+                  (function
+                    | Anonymous -> true
+                    | Name id -> not (occur_rawconstr id rtntyp)) nal
+                then (* No dependency in realargs *)
+                  None
+                else
+                  let args = List.map (fun _ -> Anonymous) params @ nal in
+                  Some (dummy_loc,ind,args) in
+              (Some rtntyp,(List.hd na,intyp)) in
+        let cs = (get_constructors env indf).(0) in
+        match indnalopt with
+          | (na,None) -> (* Represented as a let *)
+              let rec decomp_lam_force n avoid l p =
+                if n = 0 then (List.rev l,p) else
+                  match p with
+                    | 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
+                    | _ ->
+                        let x = Nameops.next_ident_away (id_of_string "x") avoid in
+                        decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+                          (* eta-expansion *)
+                          (let a = RVar (dummy_loc,x) in
+                          match p with
+                            | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+                            | _ -> (RApp (dummy_loc,p,[a]))) in
+              let (nal,d) = decomp_lam_force cs.cs_nargs [] [] f in
+              RLetTuple (loc,nal,(na,rtntypopt),c,d)
+          | _ -> (* Represented as a match *)
+            let detype_eqn constr construct_nargs branch =
+              let name_cons = function 
+                | Anonymous -> fun l -> l
+                | Name id -> fun l -> id::l in
+              let make_pat na avoid b ids =
+                PatVar (dummy_loc,na),
+                name_cons na avoid,name_cons na ids
+              in
+              let rec buildrec ids patlist avoid n b =
+                if n=0 then
+                  (dummy_loc, ids, 
+                  [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
+                  b)
+                else
+                  match b with
+	            | RLambda (_,x,_,b) -> 
+	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
+                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
+                          
+	            | RLetIn (_,x,_,b) -> 
+	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
+                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
+                          
+	            | RCast (_,c,_) ->    (* Oui, il y a parfois des cast *)
+	                buildrec ids patlist avoid n c
+                        
+	            | _ -> (* eta-expansion *)
+                        (* nommage de la nouvelle variable *)
+                        let id = Nameops.next_ident_away (id_of_string "x") avoid in
+	                let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
+                        let pat,new_avoid,new_ids =
+	                  make_pat (Name id) avoid new_b ids in
+	                buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
+	                  
+              in 
+              buildrec [] [] [] construct_nargs branch in
+            let eqn = detype_eqn (ind,1) cs.cs_nargs f in
+            RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],[eqn])
+      in
+      xx := Some c;
+      (* End building the v8 syntax *)
+      j
+
+  | RIf (loc,c,(na,po),b1,b2) ->
+      let cj = pretype empty_tycon env isevars lvar c in
+      let (IndType (indf,realargs) as indt) = 
+	try find_rectype env (evars_of isevars) 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
+      let cstrs = get_constructors env indf in 
+      if Array.length cstrs <> 2 then
+        user_err_loc (loc,"",
+	  str "If is only for inductive types with two constructors");
+
+      (* Make dependencies from arity signature impossible *)
+      let arsgn,_ = get_arity env indf in
+      let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
+      let nar = List.length arsgn in
+      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      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 pred = it_mkLambda_or_LetIn ccl psign in
+	    pred, lift (- nar) (beta_applist (pred,[cj.uj_val]))
+	| None -> 
+	    let p = match tycon with
+	    | Some ty -> ty
+	    | None -> new_isevar isevars env (loc,InternalHole) (new_Type ())
+	    in
+	    it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+      let f cs b =
+	let n = rel_context_length cs.cs_args in
+	let pi = liftn n 2 pred in
+	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+	let csgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args in
+	let env_c = push_rels csgn env in 
+	let bj = pretype (Some pi) env_c isevars 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 pred = nf_evar (evars_of isevars) pred in
+      let p = nf_evar (evars_of isevars) p in
+      let v =
+	let mis,_ = dest_ind_family indf in
+	let ci = make_default_case_info env IfStyle mis in
+	mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+      in
+      { uj_val = v; uj_type = p }
+
+  | ROrderedCase (loc,st,po,c,lf,x) ->
+      let isrec = (st = MatchStyle) in
+      let cj = pretype empty_tycon env isevars lvar c in
+      let (IndType (indf,realargs) as indt) = 
+	try find_rectype env (evars_of isevars) 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
+      let (dep,pj) = match po with
+	| Some p ->
+            let pj = pretype empty_tycon env isevars lvar p in
+            let dep = is_dependent_elimination env pj.uj_type indf in
+            let ar =
+              arity_of_case_predicate env indf dep (Type (new_univ())) in
+            let _ = the_conv_x_leq env isevars pj.uj_type ar in
+            (dep, pj)
+	| None -> 
+            (* get type information from type of branches *)
+	    let expbr = Cases.branch_scheme env isevars isrec indf in
+	    let rec findtype i =
+	      if i >= Array.length lf
+	      then
+                (* get type information from constraint *)
+                (* warning: if the constraint comes from an evar type, it *)
+                (* may be Type while Prop or Set would be expected *)
+	        match tycon with
+		  | Some pred ->
+		      let arsgn = make_arity_signature env true indf in
+                      let pred = lift (List.length arsgn) pred in
+  		      let pred = 
+			it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
+			  arsgn in
+                      (true, 
+                       Retyping.get_judgment_of env (evars_of isevars) pred)
+	          | None ->
+                      let sigma = evars_of isevars in
+                      error_cant_find_case_type_loc loc env sigma cj.uj_val
+	      else
+		try
+		  let expti = expbr.(i) in
+		  let fj =
+		    pretype (mk_tycon expti) env isevars lvar lf.(i) in
+		  let pred = 
+		    Cases.pred_case_ml (* eta-expanse *)
+                      env (evars_of isevars) isrec indt (i,fj.uj_type) in
+		  if has_undefined_isevars isevars pred then findtype (i+1)
+		  else 
+		    let pty =
+                      Retyping.get_type_of env (evars_of isevars) pred in
+		    let pj = { uj_val = pred; uj_type = pty } in
+(*
+                    let _ = option_app (the_conv_x_leq env isevars pred) tycon
+                    in
+*)
+                    (true,pj)
+		with Cases.NotInferable _ -> findtype (i+1) in
+	    findtype 0 
+      in
+      let pj = j_nf_evar (evars_of isevars) pj in
+      let pj = if dep then pj else make_dep_of_undep env indt pj in
+      let (bty,rsty) =
+	Indrec.type_rec_branches
+          isrec env (evars_of isevars) indt pj.uj_val cj.uj_val in
+      let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
+      if Array.length bty <> Array.length lf then
+	error_number_branches_loc loc env (evars_of isevars) 
+	  cj (Array.length bty)
+      else
+	let lfj =
+	  array_map2
+            (fun tyc f -> pretype (mk_tycon tyc) env isevars lvar f) bty
+            lf in
+	let lfv = Array.map j_val lfj in
+	let lft = Array.map (fun j -> j.uj_type) lfj in
+	check_branches_message loc env isevars cj.uj_val (bty,lft);
+	let v =
+	  if isrec
+	  then 
+	    transform_rec loc env (evars_of isevars)(pj,cj.uj_val,lfv) indt
+	  else
+	    let mis,_ = dest_ind_family indf in
+	    let ci = make_default_case_info env st mis in
+	    mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,
+                       Array.map (fun j-> j.uj_val) lfj)
+	in
+        (* Build the Cases form for v8 *)
+        let c =
+          let (ind,params) = dest_ind_family indf in
+          let (mib,mip) = lookup_mind_specif env ind in
+          let recargs = mip.mind_recargs in
+          let mI = mkInd ind in
+          let nconstr = Array.length mip.mind_consnames in
+          let tyi = snd ind in
+          if isrec && mis_is_recursive_subset [tyi] recargs then
+            Some (Detyping.detype (false,env)
+	      (ids_of_context env) (names_of_rel_context env)
+              (nf_evar (evars_of isevars) v))
+	  else
+	    (* Translate into a "match ... with" *)
+            let rtntypopt, indnalopt = match po with
+              | None -> None, (Anonymous,None)
+              | Some p ->
+                  let rec decomp_lam_force n avoid l p =
+                    (* avoid is not exhaustive ! *)
+                    if n = 0 then (List.rev l,p,avoid) else
+                      match p with
+                        | 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
+                        | _ ->
+                            let x = Nameops.next_ident_away (id_of_string "x") avoid in
+                            decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+                              (* eta-expansion *)
+                              (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
+                  let (nal,p,avoid) = 
+                    decomp_lam_force (List.length realargs) [] [] p in
+                  let na,rtntyopt,_ = 
+                    if dep then decomp_lam_force 1 avoid [] p
+                    else [Anonymous],p,[] in
+		  let intyp =
+		    if nal=[] then None else
+                      let args = List.map (fun _ -> Anonymous) params @ nal in
+		      Some (dummy_loc,ind,args) in
+                  (Some rtntyopt,(List.hd na,intyp)) in
+	    let rawbranches =
+	      array_map3 (fun bj b cstr ->
+		let rec strip n r = if n=0 then r else
+		  match r with
+		    | RLambda (_,_,_,t) -> strip (n-1) t
+		    | RLetIn (_,_,_,t) -> strip (n-1) t
+		    | _ -> assert false in
+		let n = rel_context_length cstr.cs_args in
+		try
+		  let _,ccl = decompose_lam_n_assum n bj.uj_val in
+		  if noccur_between 1 n ccl then Some (strip n b) else None
+		with _ -> (* Not eta-expanded or not reduced *) None)
+		lfj lf (get_constructors env indf) in
+	    if st = IfStyle & snd indnalopt = None 
+	       & rawbranches.(0) <> None && rawbranches.(1) <> None then
+	      (* Translate into a "if ... then ... else" *)
+	      (* TODO: translate into a "if" even if po is dependent *)
+	      Some (RIf (loc,c,(fst indnalopt,rtntypopt),
+	          out_some rawbranches.(0),out_some rawbranches.(1)))
+	    else
+            let detype_eqn constr construct_nargs branch =
+              let name_cons = function 
+                | Anonymous -> fun l -> l
+                | Name id -> fun l -> id::l in
+              let make_pat na avoid b ids =
+                PatVar (dummy_loc,na),
+                name_cons na avoid,name_cons na ids
+              in
+              let rec buildrec ids patlist avoid n b =
+                if n=0 then
+                  (dummy_loc, ids, 
+                  [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
+                  b)
+                else
+                  match b with
+	            | RLambda (_,x,_,b) -> 
+	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
+                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
+                          
+	            | RLetIn (_,x,_,b) -> 
+	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
+                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
+                          
+	            | RCast (_,c,_) ->    (* Oui, il y a parfois des cast *)
+	                buildrec ids patlist avoid n c
+                        
+	            | _ -> (* eta-expansion *)
+                        (* nommage de la nouvelle variable *)
+                        let id = Nameops.next_ident_away (id_of_string "x") avoid in
+	                let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
+                        let pat,new_avoid,new_ids =
+	                  make_pat (Name id) avoid new_b ids in
+	                buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
+	                  
+              in 
+              buildrec [] [] [] construct_nargs branch in
+            let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
+            let get_consnarg j = 
+              let typi = mis_nf_constructor_type (ind,mib,mip) (j+1) in
+              let _,t = decompose_prod_n_assum mip.mind_nparams typi in
+              List.rev (fst (decompose_prod_assum t)) in
+            let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
+            let consnargsl = Array.map List.length consnargs in
+            let constructs = Array.init (Array.length lf) (fun i -> (ind,i+1)) in
+            let eqns = array_map3 detype_eqn constructs consnargsl lf in
+            Some (RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],Array.to_list eqns)) in
+        x := c;
+        (* End build the Cases form for v8 *)
+	{ uj_val = v;
+	  uj_type = rsty }
+
+  | RCases (loc,po,tml,eqns) ->
+      Cases.compile_cases loc
+	((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+	tycon env (* loc *) (po,tml,eqns)
+
+  | RCast(loc,c,t) ->
+      let tj = pretype_type empty_tycon env isevars lvar t in
+      let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+      (* User Casts are for helping pretyping, experimentally not to be kept*)
+      (* ... except for Correctness *)
+      let v = mkCast (cj.uj_val, tj.utj_val) in
+      let cj = { uj_val = v; uj_type = tj.utj_val } in
+      inh_conv_coerce_to_tycon loc env isevars 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
+      j
+      (*inh_conv_coerce_to_tycon loc env isevars 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
+  | RHole loc ->
+      if !compter then nbimpl:=!nbimpl+1;
+      (match valcon with
+	 | Some v ->
+             let s =
+               let sigma = evars_of isevars 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) -> 
+                     define_evar_as_sort isevars v
+                 | _ -> 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 = new_isevar isevars env loc (mkSort s);
+	       utj_type = s})
+  | c ->
+      let j = pretype empty_tycon env isevars lvar c in
+      let tj = inh_coerce_to_sort env isevars j in
+      match valcon with
+	| None -> tj
+	| Some v ->
+	    if the_conv_x_leq env isevars v tj.utj_val then tj
+	    else
+	      error_unexpected_type_loc
+                (loc_of_rawconstr c) env (evars_of isevars) tj.utj_val v
+
+
+let unsafe_infer tycon isevars env lvar constr =
+  let j = pretype tycon env isevars lvar constr in
+  j_nf_evar (evars_of isevars) j
+
+let unsafe_infer_type valcon isevars env lvar constr =
+  let tj = pretype_type valcon env isevars lvar constr in
+  tj_nf_evar (evars_of isevars) tj
+
+(* If fail_evar is false, [process_evars] builds a meta_map with the
+   unresolved Evar that were not in initial sigma; otherwise it fail
+   on the first unresolved Evar not already in the initial sigma. *)
+(* [fail_evar] says how to process unresolved evars:
+ *   true -> raise an error message
+ *   false -> convert them into new Metas (casted with their type)
+ *)
+(* assumes the defined existentials have been replaced in c (should be
+   done in unsafe_infer and unsafe_infer_type) *)
+let check_evars fail_evar env initial_sigma isevars c =
+  let sigma = evars_of isevars in
+  let rec proc_rec c =
+    match kind_of_term c with
+      | Evar (ev,args as k) ->
+          assert (Evd.in_dom sigma ev);
+	  if not (Evd.in_dom initial_sigma ev) then
+	    (if fail_evar then
+              let (loc,k) = evar_source ev isevars in
+	       error_unsolvable_implicit loc env sigma k)
+      | _ -> iter_constr proc_rec c      
+  in
+  proc_rec 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...
+*)
+
+(* constr with holes *)
+type open_constr = evar_map * constr
+
+let ise_resolve_casted_gen fail_evar sigma env lvar typ c =
+  let isevars = create_evar_defs sigma in
+  let j = unsafe_infer (mk_tycon typ) isevars env lvar c in
+  check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
+  (evars_of isevars, j)
+
+let ise_resolve_casted sigma env typ c =
+  ise_resolve_casted_gen true sigma env ([],[]) typ c
+
+(* Raw calls to the unsafe inference machine: boolean says if we must fail
+   on unresolved evars, or replace them by Metas; the unsafe_judgment list
+   allows us to extend env with some bindings *)
+let ise_infer_gen fail_evar sigma env lvar exptyp c =
+  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
+  let isevars = create_evar_defs sigma in
+  let j = unsafe_infer tycon isevars env lvar c in
+  check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
+  (evars_of isevars, j)
+
+let ise_infer_type_gen fail_evar sigma env lvar c =
+  let isevars = create_evar_defs sigma in
+  let tj = unsafe_infer_type empty_valcon isevars env lvar c in
+  check_evars fail_evar env sigma isevars tj.utj_val;
+  (evars_of isevars, tj)
+
+type var_map = (identifier * unsafe_judgment) list
+
+let understand_judgment sigma env c =
+  snd (ise_infer_gen true sigma env ([],[]) None c)
+
+let understand_type_judgment sigma env c =
+  snd (ise_infer_type_gen true sigma env ([],[]) c)
+
+let understand sigma env c =
+  let _, c = ise_infer_gen true sigma env ([],[]) None c in
+  c.uj_val
+
+let understand_type sigma env c =
+  let _,c = ise_infer_type_gen true sigma env ([],[]) c in
+  c.utj_val
+
+let understand_gen_ltac sigma env lvar ~expected_type:exptyp c =
+  let _, c = ise_infer_gen true sigma env lvar exptyp c in
+  c.uj_val
+
+let understand_gen sigma env lvar ~expected_type:exptyp c =
+  let _, c = ise_infer_gen true sigma env (lvar,[]) exptyp c in
+  c.uj_val
+
+let understand_gen_tcc sigma env lvar exptyp c =
+  let metamap, c = ise_infer_gen false sigma env (lvar,[]) exptyp c in
+  metamap, c.uj_val
+
+let interp_sort = function
+  | RProp c -> Prop c
+  | RType _ -> new_Type_sort ()
+
+let interp_elimination_sort = function
+  | RProp Null -> InProp
+  | RProp Pos  -> InSet
+  | RType _ -> InType
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
new file mode 100644
index 00000000..4357e504
--- /dev/null
+++ b/pretyping/pretyping.mli
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  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: pretyping.mli,v 1.28.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Sign
+open Term
+open Environ
+open Evd
+open Rawterm
+open Evarutil
+(*i*)
+
+type var_map = (identifier * unsafe_judgment) list
+
+(* constr with holes *)
+type open_constr = evar_map * constr
+
+
+(* Generic call to the interpreter from rawconstr to constr, failing
+   unresolved holes in the rawterm cannot be instantiated.
+
+   In [understand_gen sigma env varmap typopt raw],
+
+   sigma : initial set of existential variables (typically dependent subgoals)
+   varmap : partial subtitution of variables (used for the tactic language)
+   metamap : partial subtitution of meta (used for the tactic language)
+   typopt : is not None, this is the expected type for raw (used to define evars)
+*)
+val understand_gen :
+  evar_map -> env -> var_map
+    -> expected_type:(constr option) -> rawconstr -> constr
+
+val understand_gen_ltac :
+  evar_map -> env -> var_map * (identifier * identifier option) list
+    -> expected_type:(constr option) -> rawconstr -> constr
+
+(* Generic call to the interpreter from rawconstr to constr, turning
+   unresolved holes into metas. Returns also the typing context of
+   these metas. Work as [understand_gen] for the rest. *)
+val understand_gen_tcc :
+  evar_map -> env -> var_map
+    -> constr option -> rawconstr -> open_constr
+
+(* Standard call to get a constr from a rawconstr, resolving implicit args *)
+val understand : evar_map -> env -> rawconstr -> constr
+
+(* Idem but the rawconstr is intended to be a type *)
+val understand_type : evar_map -> env -> rawconstr -> constr
+
+(* Idem but returns the judgment of the understood term *)
+val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+
+(* Idem but returns the judgment of the understood type *)
+val understand_type_judgment : evar_map -> env -> rawconstr 
+  -> unsafe_type_judgment
+
+(* To embed constr in rawconstr *)
+val constr_in : constr -> Dyn.t
+val constr_out : Dyn.t -> constr
+
+(*i*)
+(* Internal of Pretyping...
+ * Unused outside, but useful for debugging
+ *)
+val pretype : 
+  type_constraint -> env -> evar_defs -> 
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_judgment
+
+val pretype_type : 
+  val_constraint -> env -> evar_defs ->
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_type_judgment
+(*i*)
+
+val interp_sort : rawsort -> sorts
+
+val interp_elimination_sort : rawsort -> sorts_family
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
new file mode 100644
index 00000000..520f09e9
--- /dev/null
+++ b/pretyping/rawterm.ml
@@ -0,0 +1,365 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: rawterm.ml,v 1.43.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Sign
+open Term
+open Libnames
+open Nametab
+(*i*)
+
+(* Untyped intermediate terms, after ASTs and before constr. *)
+
+(* locs here refers to the ident's location, not whole pat *)
+(* the last argument of PatCstr is a possible alias ident for the pattern *)
+type cases_pattern =
+  | PatVar of loc * name
+  | PatCstr of loc * constructor * cases_pattern list * name
+
+let pattern_loc = function
+    PatVar(loc,_) -> loc
+  | PatCstr(loc,_,_,_) -> loc
+
+type patvar = identifier
+
+type rawsort = RProp of Term.contents | RType of Univ.universe option
+
+type fix_kind = RFix of (int array * int) | RCoFix of int
+
+type binder_kind = BProd | BLambda | BLetIn
+
+type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
+
+type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
+
+type 'a bindings = 
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+type hole_kind =
+  | ImplicitArg of global_reference * int
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+
+type rawconstr = 
+  | RRef of (loc * global_reference)
+  | RVar of (loc * identifier)
+  | 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
+  | RLetIn of loc * name * rawconstr * rawconstr
+  | RCases of loc * (rawconstr option * rawconstr option ref) *
+      (rawconstr * (name * (loc * inductive * name list) option) ref) list * 
+      (loc * identifier list * cases_pattern list * rawconstr) list
+  | ROrderedCase of loc * case_style * rawconstr option * rawconstr * 
+      rawconstr array * rawconstr option ref
+  | RLetTuple of loc * name list * (name * rawconstr option) * 
+      rawconstr * rawconstr
+  | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
+  | RRec of loc * fix_kind * identifier array * rawdecl list array *
+      rawconstr array * rawconstr array
+  | RSort of loc * rawsort
+  | RHole of (loc * hole_kind)
+  | RCast of loc * rawconstr * rawconstr
+  | RDynamic of loc * Dyn.t
+
+and rawdecl = name * rawconstr option * rawconstr
+
+let cases_predicate_names tml =
+  List.flatten (List.map (function
+    | (tm,{contents=(na,None)}) -> [na]
+    | (tm,{contents=(na,Some (_,_,nal))}) -> na::nal) tml)
+
+(*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
+   arities incrementally lifted 
+
+  [On pourrait plutot mettre les arités aves le type qu'elles auront
+   dans le contexte servant à typer les body ???]
+
+   - boolean in POldCase means it is recursive
+i*)
+let map_rawdecl f (na,obd,ty) = (na,option_app 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)
+  | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c)
+  | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
+      RCases (loc,(option_app f tyopt,ref (option_app f !rtntypopt)),
+        List.map (fun (tm,x) -> (f tm,x)) tml,
+        List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl)
+  | ROrderedCase (loc,b,tyopt,tm,bv,x) ->
+      ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv,ref (option_app f !x))
+  | RLetTuple (loc,nal,(na,po),b,c) ->
+      RLetTuple (loc,nal,(na,option_app f po),f b,f c)
+  | RIf (loc,c,(na,po),b1,b2) ->
+      RIf (loc,f c,(na,option_app 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)
+  | RCast (loc,c,t) -> RCast (loc,f c,f t)
+  | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
+  
+
+(*
+let name_app f e = function
+  | Name id -> let (id, e) = f id e in (Name id, e)
+  | Anonymous -> Anonymous, e
+
+let fold_ident g idl e =
+  let (idl,e) =
+    Array.fold_right
+      (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e)
+  in (Array.of_list idl,e)
+
+let map_rawconstr_with_binders_loc loc g f e = function
+  | RVar (_,id) -> RVar (loc,id)
+  | RApp (_,a,args) -> RApp (loc,f e a, List.map (f e) args)
+  | RLambda (_,na,ty,c) ->
+      let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c)
+  | RProd (_,na,ty,c) ->
+      let na,e = name_app g e na in RProd (loc,na,f e ty,f e c)
+  | RLetIn (_,na,b,c) ->
+      let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c)
+  | RCases (_,tyopt,tml,pl) ->
+      (* We don't modify pattern variable since we don't traverse patterns *)
+      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_app (f e) tyopt,List.map (f e) tml, List.map h pl)
+  | ROrderedCase (_,b,tyopt,tm,bv) ->
+      ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv)
+  | 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)
+  | RCast (_,c,t) -> RCast (loc,f e c,f e t)
+  | RSort (_,x) -> RSort (loc,x)
+  | RHole (_,x)  -> RHole (loc,x)
+  | RRef (_,x) -> RRef (loc,x)
+  | REvar (_,x,l) -> REvar (loc,x,l)
+  | RPatVar (_,x) -> RPatVar (loc,x)
+  | RDynamic (_,x) -> RDynamic (loc,x)
+*)
+
+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))
+    | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
+    | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
+	(occur_option tyopt) or (occur_option !rtntypopt)
+        or (List.exists (fun (tm,_) -> occur tm) tml)
+	or (List.exists occur_pattern pl)
+    | ROrderedCase (loc,b,tyopt,tm,bv,_) -> 
+	(occur_option tyopt) or (occur tm) or (array_exists occur bv)
+    | RLetTuple (loc,nal,rtntyp,b,c) -> 
+	occur_return_type rtntyp id
+        or (occur b) or (not (List.mem (Name id) nal) & (occur c))
+    | RIf (loc,c,rtntyp,b1,b2) -> 
+	occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2)
+    | RRec (loc,fk,idl,bl,tyl,bv) ->
+        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 ->
+                not (occur bty) &&
+                (match bbd with
+                    Some bd -> not (occur bd)
+                  | _ -> true) &&
+                (na=Name id or not(occur_fix bl)) in
+          occur_fix bl)
+          idl bl tyl bv)
+    | RCast (loc,c,t) -> (occur c) or (occur t)
+    | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false
+
+  and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
+
+  and occur_option = function None -> false | Some p -> occur p
+
+  and occur_return_type (na,tyopt) id = na <> Name id & occur_option tyopt
+
+  in occur
+
+let rec subst_pat subst pat = 
+  match pat with
+  | PatVar _ -> pat
+  | PatCstr (loc,((kn,i),j),cpl,n) -> 
+      let kn' = subst_kn subst kn 
+      and cpl' = list_smartmap (subst_pat subst) cpl in
+	if kn' == kn && cpl' == cpl then pat else
+	  PatCstr (loc,((kn',i),j),cpl',n)
+
+let rec subst_raw subst raw = 
+  match raw with
+  | RRef (loc,ref) -> 
+      let ref' = subst_global subst ref in 
+	if ref' == ref then raw else
+	  RRef (loc,ref')
+
+  | RVar _ -> raw
+  | REvar _ -> raw
+  | RPatVar _ -> raw
+
+  | RApp (loc,r,rl) -> 
+      let r' = subst_raw subst r 
+      and rl' = list_smartmap (subst_raw subst) rl in
+	if r' == r && rl' == rl then raw else
+	  RApp(loc,r',rl')
+
+  | RLambda (loc,n,r1,r2) -> 
+      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RLambda (loc,n,r1',r2')
+
+  | RProd (loc,n,r1,r2) -> 
+      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RProd (loc,n,r1',r2')
+
+  | RLetIn (loc,n,r1,r2) -> 
+      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RLetIn (loc,n,r1',r2')
+
+  | RCases (loc,(ro,rtno),rl,branches) -> 
+      let ro' = option_smartmap (subst_raw subst) ro 
+      and rtno' = ref (option_smartmap (subst_raw subst) !rtno)
+      and rl' = list_smartmap (fun (a,x as y) ->
+        let a' = subst_raw subst a in
+        let (n,topt) = !x in 
+        let topt' = option_smartmap
+          (fun (loc,(sp,i),x as t) ->
+            let sp' = subst_kn subst sp in
+            if sp == sp' then t else (loc,(sp',i),x)) topt in
+        if a == a' && topt == topt' then y else (a',ref (n,topt'))) rl
+      and branches' = list_smartmap 
+			(fun (loc,idl,cpl,r as branch) ->
+			   let cpl' = list_smartmap (subst_pat subst) cpl
+			   and r' = subst_raw subst r in
+			     if cpl' == cpl && r' == r then branch else
+			       (loc,idl,cpl',r'))
+			branches
+      in
+	if ro' == ro && rl' == rl && branches' == branches then raw else
+	  RCases (loc,(ro',rtno'),rl',branches')
+
+  | ROrderedCase (loc,b,ro,r,ra,x) -> 
+      let ro' = option_smartmap (subst_raw subst) ro
+      and r' = subst_raw subst r 
+      and ra' = array_smartmap (subst_raw subst) ra in
+	if ro' == ro && r' == r && ra' == ra then raw else
+	  ROrderedCase (loc,b,ro',r',ra',x)
+
+  | RLetTuple (loc,nal,(na,po),b,c) ->
+      let po' = option_smartmap (subst_raw subst) po
+      and b' = subst_raw subst b 
+      and c' = subst_raw 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_raw subst) po
+      and b1' = subst_raw subst b1 
+      and b2' = subst_raw subst b2 
+      and c' = subst_raw subst c in
+	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
+          RIf (loc,c',(na,po'),b1',b2')
+
+  | RRec (loc,fix,ida,bl,ra1,ra2) -> 
+      let ra1' = array_smartmap (subst_raw subst) ra1
+      and ra2' = array_smartmap (subst_raw subst) ra2 in
+      let bl' = array_smartmap
+        (list_smartmap (fun (na,obd,ty as dcl) ->
+          let ty' = subst_raw subst ty in
+          let obd' = option_smartmap (subst_raw subst) obd in
+          if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
+        bl in
+	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
+	  RRec (loc,fix,ida,bl',ra1',ra2')
+
+  | RSort _ -> raw
+
+  | RHole (loc,ImplicitArg (ref,i)) ->
+      let ref' = subst_global subst ref in 
+	if ref' == ref then raw else
+	  RHole (loc,ImplicitArg (ref',i))
+  | RHole (loc, (BinderType _ | QuestionMark | CasesType |
+      InternalHole | TomatchTypeParameter _)) -> raw
+
+  | RCast (loc,r1,r2) -> 
+      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RCast (loc,r1',r2')
+
+  | RDynamic _ -> raw
+
+let loc_of_rawconstr = function
+  | RRef (loc,_) -> loc
+  | RVar (loc,_) -> loc
+  | REvar (loc,_,_) -> loc
+  | RPatVar (loc,_) -> loc
+  | RApp (loc,_,_) -> loc
+  | RLambda (loc,_,_,_) -> loc
+  | RProd (loc,_,_,_) -> loc
+  | RLetIn (loc,_,_,_) -> loc
+  | RCases (loc,_,_,_) -> loc
+  | ROrderedCase (loc,_,_,_,_,_) -> loc
+  | RLetTuple (loc,_,_,_,_) -> loc
+  | RIf (loc,_,_,_,_) -> loc
+  | RRec (loc,_,_,_,_,_) -> loc
+  | RSort (loc,_) -> loc
+  | RHole (loc,_) -> loc
+  | RCast (loc,_,_) -> loc
+  | RDynamic (loc,_) -> loc
+
+type 'a raw_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+let all_flags =
+  {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
+
+type 'a occurrences = int list * 'a
+
+type ('a,'b) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'a occurrences option
+  | Cbv of 'b raw_red_flag
+  | Lazy of 'b raw_red_flag
+  | Unfold of 'b occurrences list
+  | Fold of 'a list
+  | Pattern of 'a occurrences list
+  | ExtraRedExpr of string * 'a
+
+type ('a,'b) may_eval =
+  | ConstrTerm of 'a
+  | ConstrEval of ('a, 'b) red_expr_gen * 'a
+  | ConstrContext of (loc * identifier) * 'a
+  | ConstrTypeOf of 'a
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
new file mode 100644
index 00000000..d78d1866
--- /dev/null
+++ b/pretyping/rawterm.mli
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  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: rawterm.mli,v 1.47.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Sign
+open Term
+open Libnames
+open Nametab
+(*i*)
+
+(* Untyped intermediate terms, after ASTs and before constr. *)
+
+(* locs here refers to the ident's location, not whole pat *)
+(* the last argument of PatCstr is a possible alias ident for the pattern *)
+type cases_pattern =
+  | PatVar of loc * name
+  | PatCstr of loc * constructor * cases_pattern list * name
+
+val pattern_loc : cases_pattern -> loc
+
+type patvar = identifier
+
+type rawsort = RProp of Term.contents | RType of Univ.universe option
+
+type fix_kind = RFix of (int array * int) | RCoFix of int
+
+type binder_kind = BProd | BLambda | BLetIn
+
+type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
+
+type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
+
+type 'a bindings = 
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+type hole_kind =
+  | ImplicitArg of global_reference * int
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+
+type rawconstr = 
+  | RRef of (loc * global_reference)
+  | RVar of (loc * identifier)
+  | 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
+  | RLetIn of loc * name * rawconstr * rawconstr
+  | RCases of loc * (rawconstr option * rawconstr option ref) *
+      (rawconstr * (name * (loc * inductive * name list) option) ref) list * 
+      (loc * identifier list * cases_pattern list * rawconstr) list
+  | ROrderedCase of loc * case_style * rawconstr option * rawconstr * 
+      rawconstr array * rawconstr option ref
+  | RLetTuple of loc * name list * (name * rawconstr option) * 
+      rawconstr * rawconstr
+  | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
+  | RRec of loc * fix_kind * identifier array * rawdecl list array *
+      rawconstr array * rawconstr array
+  | RSort of loc * rawsort
+  | RHole of (loc * hole_kind)
+  | RCast of loc * rawconstr * rawconstr
+  | RDynamic of loc * Dyn.t
+
+and rawdecl = name * rawconstr option * rawconstr
+
+val cases_predicate_names : 
+  (rawconstr * (name * (loc * inductive * name list) option) ref) list ->
+      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
+   arities incrementally lifted 
+
+  [On pourrait plutot mettre les arités aves le type qu'elles auront
+   dans le contexte servant à typer les body ???]
+
+   - boolean in POldCase means it is recursive
+   - option in PHole tell if the "?" was apparent or has been implicitely added
+i*)
+
+val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr
+
+(*
+val map_rawconstr_with_binders_loc : loc -> 
+  (identifier -> 'a -> identifier * 'a) ->
+  ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr
+*)
+
+val occur_rawconstr : identifier -> rawconstr -> bool
+
+val loc_of_rawconstr : rawconstr -> loc
+
+val subst_raw : Names.substitution -> rawconstr -> rawconstr
+
+type 'a raw_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+val all_flags : 'a raw_red_flag
+
+type 'a occurrences = int list * 'a
+
+type ('a,'b) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'a occurrences option
+  | Cbv of 'b raw_red_flag
+  | Lazy of 'b raw_red_flag
+  | Unfold of 'b occurrences list
+  | Fold of 'a list
+  | Pattern of 'a occurrences list
+  | ExtraRedExpr of string * 'a
+
+type ('a,'b) may_eval =
+  | ConstrTerm of 'a
+  | ConstrEval of ('a, 'b) red_expr_gen * 'a
+  | ConstrContext of (loc * identifier) * 'a
+  | ConstrTypeOf of 'a
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
new file mode 100755
index 00000000..f34d5624
--- /dev/null
+++ b/pretyping/recordops.ml
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: recordops.ml,v 1.26.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Libnames
+open Nametab
+open Term
+open Termops
+open Typeops
+open Libobject
+open Library
+open Classops
+
+let nbimpl = ref 0
+let nbpathc = ref 0
+let nbcoer = ref 0
+let nbstruc = ref 0
+let nbimplstruc = ref 0
+
+let compter = ref false
+
+(*s Une structure S est un type inductif non récursif à un seul
+   constructeur (de nom par défaut Build_S) *)
+
+(* Table des structures: le nom de la structure (un [inductive]) donne
+   le nom du constructeur, le nombre de paramètres et pour chaque
+   argument réels du constructeur, le noms de la projection
+   correspondante, si valide *)
+
+type struc_typ = {
+  s_CONST : identifier; 
+  s_PARAM : int;
+  s_PROJ : constant option list }
+
+let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
+let projection_table = ref KNmap.empty
+
+let option_fold_right f p e = match p with Some a -> f a e | None -> e
+
+let cache_structure (_,(ind,struc)) =
+  structure_table := Indmap.add ind struc !structure_table;
+  projection_table := 
+    List.fold_right (option_fold_right (fun proj -> KNmap.add proj struc))
+      struc.s_PROJ !projection_table
+
+let subst_structure (_,subst,((kn,i),struc as obj)) = 
+  let kn' = subst_kn subst kn in
+  let proj' = list_smartmap 
+		(option_smartmap (subst_kn subst)) 
+		struc.s_PROJ 
+  in
+    if proj' == struc.s_PROJ && kn' == kn then obj else
+      (kn',i),{struc with s_PROJ = proj'}
+
+let (inStruc,outStruc) =
+  declare_object {(default_object "STRUCTURE") with 
+                    cache_function = cache_structure;
+		    load_function = (fun _ o -> cache_structure o);
+                    subst_function = subst_structure;
+		    classify_function = (fun (_,x) -> Substitute x);
+		    export_function = (function x -> Some x)  }
+
+let add_new_struc (s,c,n,l) = 
+  Lib.add_anonymous_leaf (inStruc (s,{s_CONST=c;s_PARAM=n;s_PROJ=l}))
+
+let find_structure indsp = Indmap.find indsp !structure_table
+
+let find_projection_nparams = function
+  | ConstRef cst -> (KNmap.find cst !projection_table).s_PARAM
+  | _ -> raise Not_found
+
+(*s Un "object" est une fonction construisant une instance d'une structure *)
+
+(* Table des definitions "object" : pour chaque object c,
+
+  c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n)
+
+  avec ti = (ci ui1...uir)
+
+  Pour tout ci, et Li, la ième projection de la structure R (si
+  définie), on déclare une "coercion"
+
+    o_DEF = c
+    o_TABS = B1...Bk
+    o_PARAMS = a1...am
+    o_TCOMP = ui1...uir
+*)
+
+type obj_typ = {
+  o_DEF : constr;
+  o_TABS : constr list;    (* dans l'ordre *)
+  o_TPARAMS : constr list; (* dans l'ordre *)
+  o_TCOMPS : constr list } (* dans l'ordre *)
+
+let subst_obj subst obj =
+  let o_DEF' = subst_mps subst obj.o_DEF in
+  let o_TABS' = list_smartmap (subst_mps subst) obj.o_TABS in    
+  let o_TPARAMS' = list_smartmap (subst_mps subst) obj.o_TPARAMS in 
+  let o_TCOMPS' = list_smartmap (subst_mps subst) obj.o_TCOMPS in 
+    if o_DEF' == obj.o_DEF
+      && o_TABS' == obj.o_TABS    
+      && o_TPARAMS' == obj.o_TPARAMS 
+      && o_TCOMPS' == obj.o_TCOMPS 
+    then 
+      obj
+    else
+      { o_DEF = o_DEF' ;
+	o_TABS = o_TABS' ;    
+	o_TPARAMS = o_TPARAMS' ; 
+	o_TCOMPS = o_TCOMPS' }
+
+let object_table =
+  (ref [] : ((global_reference * global_reference) * obj_typ) list ref)
+
+let cache_object (_,x) = object_table := x :: (!object_table)
+
+let subst_object (_,subst,((r1,r2),o as obj)) = 
+  let r1' = subst_global subst r1 in
+  let r2' = subst_global subst r2 in
+  let o' = subst_obj subst o in
+    if r1' == r1 && r2' == r2 && o' == o then obj else
+      (r1',r2'),o'
+
+let (inObjDef,outObjDef) =
+  declare_object {(default_object "OBJDEF") with 
+		    open_function = (fun i o -> if i=1 then cache_object o);
+                    cache_function = cache_object;
+		    subst_function = subst_object;
+		    classify_function = (fun (_,x) -> Substitute x);
+                    export_function = (function x -> Some x) }
+
+let add_new_objdef (o,c,la,lp,l) =
+  try 
+    let _ = List.assoc o !object_table in ()
+  with Not_found -> 
+    Lib.add_anonymous_leaf
+      (inObjDef (o,{o_DEF=c;o_TABS=la;o_TPARAMS=lp;o_TCOMPS=l}))
+
+let cache_objdef1 (_,sp) = ()
+
+let (inObjDef1,outObjDef1) =
+  declare_object {(default_object "OBJDEF1") with 
+		    open_function = (fun i o -> if i=1 then cache_objdef1 o);
+                    cache_function = cache_objdef1;
+                    export_function = (function x -> Some x) }
+
+let objdef_info o = List.assoc o !object_table
+
+let freeze () =
+  !structure_table, !projection_table, !object_table
+
+let unfreeze (s,p,o) = 
+  structure_table := s; projection_table := p; object_table := o
+
+let init () =
+  structure_table := Indmap.empty; projection_table := KNmap.empty;
+  object_table:=[]
+
+let _ = init()
+
+let _ = 
+  Summary.declare_summary "objdefs"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
new file mode 100755
index 00000000..66c1f34d
--- /dev/null
+++ b/pretyping/recordops.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  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: recordops.mli,v 1.15.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Nametab
+open Term
+open Libnames
+open Classops
+open Libobject
+open Library
+(*i*)
+
+val nbimpl : int ref
+val nbpathc : int ref
+val nbcoer : int ref
+val nbstruc : int ref
+val nbimplstruc : int ref
+val compter : bool ref
+
+type struc_typ = {
+  s_CONST : identifier; 
+  s_PARAM : int;
+  s_PROJ : constant option list }
+
+val add_new_struc : 
+  inductive * identifier * int * constant option list -> unit
+
+(* [find_structure isp] returns the infos associated to inductive path
+   [isp] if it corresponds to a structure, otherwise fails with [Not_found] *)
+val find_structure : inductive -> struc_typ
+
+(* raise [Not_found] if not a projection *)
+val find_projection_nparams : global_reference -> int
+
+type obj_typ = {
+  o_DEF : constr;
+  o_TABS : constr list; (* dans l'ordre *)
+  o_TPARAMS : constr list; (* dans l'ordre *)
+  o_TCOMPS : constr list } (* dans l'ordre *)
+               
+val objdef_info : (global_reference * global_reference) -> obj_typ
+val add_new_objdef : 
+  (global_reference * global_reference) * Term.constr * Term.constr list *
+  Term.constr list * Term.constr list -> unit
+
+
+val inStruc : inductive * struc_typ -> obj
+val outStruc : obj -> inductive * struc_typ
+val inObjDef1 : kernel_name -> obj
+val outObjDef1 : obj -> kernel_name
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
new file mode 100644
index 00000000..a030dcf2
--- /dev/null
+++ b/pretyping/reductionops.ml
@@ -0,0 +1,717 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: reductionops.ml,v 1.6.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Univ
+open Evd
+open Declarations
+open Environ
+open Instantiate
+open Closure
+open Esubst
+open Reduction
+
+exception Elimconst
+
+(* The type of (machine) states (= lambda-bar-calculus' cuts) *) 
+type state = constr * constr stack
+
+type  contextual_reduction_function = env ->  evar_map -> constr -> constr
+type  reduction_function =  contextual_reduction_function
+type local_reduction_function = constr -> constr
+
+type  contextual_stack_reduction_function = 
+    env ->  evar_map -> constr -> constr * constr list
+type  stack_reduction_function =  contextual_stack_reduction_function
+type local_stack_reduction_function = constr -> constr * constr list
+
+type  contextual_state_reduction_function = 
+    env ->  evar_map -> state -> state
+type  state_reduction_function =  contextual_state_reduction_function
+type local_state_reduction_function = state -> state
+
+(*************************************)
+(*** Reduction Functions Operators ***)
+(*************************************)
+
+let rec whd_state (x, stack as s) =
+  match kind_of_term x with
+    | App (f,cl) -> whd_state (f, append_stack cl stack)
+    | Cast (c,_)  -> whd_state (c, stack)
+    | _             -> s
+
+let appterm_of_stack (f,s) = (f,list_of_stack s)
+
+let whd_stack x = appterm_of_stack (whd_state (x, empty_stack))
+let whd_castapp_stack = whd_stack
+
+let stack_reduction_of_reduction red_fun env sigma s =
+  let t = red_fun env sigma (app_stack s) in
+  whd_stack t
+
+let strong whdfun env sigma t = 
+  let rec strongrec env t =
+    map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in
+  strongrec env t
+
+let local_strong whdfun = 
+  let rec strongrec t = map_constr strongrec (whdfun t) in
+  strongrec
+
+let rec strong_prodspine redfun c = 
+  let x = redfun c in
+  match kind_of_term x with
+    | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun b)
+    | _ -> x
+
+(*************************************)
+(*** Reduction using bindingss ***)
+(*************************************)
+
+(* This signature is very similar to Closure.RedFlagsSig except there
+   is eta but no per-constant unfolding *)
+
+module type RedFlagsSig = sig
+  type flags
+  type flag
+  val fbeta : flag
+  val fevar : flag
+  val fdelta : flag
+  val feta : flag
+  val fiota : flag
+  val fzeta : flag
+  val mkflags : flag list -> flags
+  val red_beta : flags -> bool
+  val red_delta : flags -> bool
+  val red_evar : flags -> bool
+  val red_eta : flags -> bool
+  val red_iota : flags -> bool
+  val red_zeta : flags -> bool
+end
+
+(* Naive Implementation 
+module RedFlags = (struct
+  type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA
+  type flags = flag list
+  let fbeta = BETA 
+  let fdelta = DELTA
+  let fevar = EVAR
+  let fiota = IOTA
+  let fzeta = ZETA
+  let feta = ETA
+  let mkflags l = l
+  let red_beta = List.mem BETA
+  let red_delta = List.mem DELTA
+  let red_evar = List.mem EVAR
+  let red_eta = List.mem ETA
+  let red_iota = List.mem IOTA
+  let red_zeta = List.mem ZETA
+end : RedFlagsSig)
+*)
+
+(* Compact Implementation *)
+module RedFlags = (struct
+  type flag = int
+  type flags = int
+  let fbeta = 1
+  let fdelta = 2
+  let fevar = 4
+  let feta = 8 
+  let fiota = 16
+  let fzeta = 32
+  let mkflags = List.fold_left (lor) 0
+  let red_beta f = f land fbeta <> 0
+  let red_delta f = f land fdelta <> 0
+  let red_evar f = f land fevar <> 0
+  let red_eta f = f land feta <> 0
+  let red_iota f = f land fiota <> 0
+  let red_zeta f = f land fzeta <> 0
+end : RedFlagsSig)
+
+open RedFlags
+
+(* Local *)
+let beta = mkflags [fbeta]
+let evar = mkflags [fevar]
+let betaevar = mkflags [fevar; fbeta]
+let betaiota = mkflags [fiota; fbeta]
+let betaiotazeta = mkflags [fiota; fbeta;fzeta]
+
+(* Contextual *)
+let delta = mkflags [fdelta;fevar]
+let betadelta = mkflags [fbeta;fdelta;fzeta;fevar]
+let betadeltaeta = mkflags [fbeta;fdelta;fzeta;fevar;feta]
+let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fevar;fiota]
+let betadeltaiota_nolet = mkflags [fbeta;fdelta;fevar;fiota]
+let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fevar;fiota;feta]
+let betaiotaevar = mkflags [fbeta;fiota;fevar]
+let betaetalet = mkflags [fbeta;feta;fzeta]
+let betalet = mkflags [fbeta;fzeta]
+
+(* Beta Reduction tools *)
+
+let rec stacklam recfun env t stack =
+  match (decomp_stack stack,kind_of_term t) with
+    | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl
+    | _ -> recfun (substl env t, stack)
+
+let beta_applist (c,l) =
+  stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack)
+
+(* Iota reduction tools *)
+
+type 'a miota_args = {
+  mP      : constr;     (* the result type *)
+  mconstr : constr;     (* the constructor *)
+  mci     : case_info;  (* special info to re-build pattern *)
+  mcargs  : 'a list;    (* the constructor's arguments *)
+  mlf     : 'a array }  (* the branch code vector *)
+		       
+let reducible_mind_case c = match kind_of_term c with
+  | Construct _ | CoFix _ -> true
+  | _  -> false
+
+let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
+  let nbodies = Array.length bodies in
+  let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in
+  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+
+let reduce_mind_case mia =
+  match kind_of_term mia.mconstr with
+    | Construct (ind_sp,i as cstr_sp) ->
+(*	let ncargs = (fst mia.mci).(i-1) in*)
+	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
+        applist (mia.mlf.(i-1),real_cargs)
+    | CoFix cofix ->
+	let cofix_def = contract_cofix cofix in
+	mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf)
+    | _ -> assert false
+
+(* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce
+   Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *)
+
+let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) =
+  let nbodies = Array.length recindices in
+  let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in
+  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+
+let fix_recarg ((recindices,bodynum),_) stack =
+  assert (0 <= bodynum & bodynum < Array.length recindices);
+  let recargnum = Array.get recindices bodynum in
+  try 
+    Some (recargnum, stack_nth stack recargnum)
+  with Not_found ->
+    None
+
+type fix_reduction_result = NotReducible | Reduced of state
+
+let reduce_fix whdfun fix stack =
+  match fix_recarg fix stack with
+    | None -> NotReducible
+    | Some (recargnum,recarg) ->
+        let (recarg'hd,_ as recarg') = whdfun (recarg, empty_stack) in
+        let stack' = stack_assign stack recargnum (app_stack recarg') in
+	(match kind_of_term recarg'hd with
+           | Construct _ -> Reduced (contract_fix fix, stack')
+	   | _ -> NotReducible)
+
+(* Generic reduction function *)
+
+(* Y avait un commentaire pour whd_betadeltaiota :
+
+   NB : Cette fonction alloue peu c'est l'appel 
+     ``let (c,cargs) = whfun (recarg, empty_stack)''
+                              -------------------
+   qui coute cher *)
+
+let rec whd_state_gen flags env sigma = 
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | Rel n when red_delta flags ->
+	  (match lookup_rel n env with
+	     | (_,Some body,_) -> whrec (lift n body, stack)
+	     | _ -> s)
+      | Var id when red_delta flags ->
+	  (match lookup_named id env with
+	     | (_,Some body,_) -> whrec (body, stack)
+	     | _ -> s)
+      | Evar ev when red_evar flags ->
+	  (match existential_opt_value sigma ev with
+	     | Some body -> whrec (body, stack)
+	     | None -> s)
+      | Const const when red_delta flags ->
+	  (match constant_opt_value env const with
+	     | Some  body -> whrec (body, stack)
+	     | None -> s)
+      | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
+      | Cast (c,_) -> whrec (c, stack)
+      | App (f,cl)  -> whrec (f, append_stack cl stack)
+      | Lambda (na,t,c) ->
+          (match decomp_stack stack with
+             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
+             | None when red_eta flags ->
+		 let env' = push_rel (na,None,t) env in
+		 let whrec' = whd_state_gen flags env' sigma in
+                 (match kind_of_term (app_stack (whrec' (c, empty_stack))) with
+                    | App (f,cl) ->
+			let napp = Array.length cl in
+			if napp > 0 then
+			  let x', l' = whrec' (array_last cl, empty_stack) in
+                          match kind_of_term x', decomp_stack l' with
+                            | Rel 1, None ->
+				let lc = Array.sub cl 0 (napp-1) in
+				let u = if napp=1 then f else appvect (f,lc) in
+				if noccurn 1 u then (pop u,empty_stack) else s
+                            | _ -> s
+			else s
+		    | _ -> s)
+	     | _ -> s)
+
+      | Case (ci,p,d,lf) when red_iota flags ->
+          let (c,cargs) = whrec (d, empty_stack) in
+          if reducible_mind_case c then
+            whrec (reduce_mind_case
+                     {mP=p; mconstr=c; mcargs=list_of_stack cargs;
+		      mci=ci; mlf=lf}, stack)
+          else 
+	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
+            
+      | Fix fix when red_iota flags ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+
+      | x -> s
+  in 
+  whrec
+
+let local_whd_state_gen flags = 
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
+      | Cast (c,_) -> whrec (c, stack)
+      | App (f,cl)  -> whrec (f, append_stack cl stack)
+      | Lambda (_,_,c) ->
+          (match decomp_stack stack with
+             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
+             | None when red_eta flags ->
+                 (match kind_of_term (app_stack (whrec (c, empty_stack))) with 
+                    | App (f,cl) ->
+			let napp = Array.length cl in
+			if napp > 0 then
+			  let x', l' = whrec (array_last cl, empty_stack) in
+                          match kind_of_term x', decomp_stack l' with
+                            | Rel 1, None ->
+				let lc = Array.sub cl 0 (napp-1) in
+				let u = if napp=1 then f else appvect (f,lc) in
+				if noccurn 1 u then (pop u,empty_stack) else s
+                            | _ -> s
+			else s
+		    | _ -> s)
+	     | _ -> s)
+
+      | Case (ci,p,d,lf) when red_iota flags ->
+          let (c,cargs) = whrec (d, empty_stack) in
+          if reducible_mind_case c then
+            whrec (reduce_mind_case
+                     {mP=p; mconstr=c; mcargs=list_of_stack cargs;
+		      mci=ci; mlf=lf}, stack)
+          else 
+	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
+            
+      | Fix fix when red_iota flags ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+
+      | x -> s
+  in 
+  whrec
+
+(* 1. Beta Reduction Functions *)
+
+let whd_beta_state = local_whd_state_gen beta
+let whd_beta_stack x = appterm_of_stack (whd_beta_state (x, empty_stack))
+let whd_beta x = app_stack (whd_beta_state (x,empty_stack))
+
+(* Nouveau ! *)
+let whd_betaetalet_state = local_whd_state_gen betaetalet
+let whd_betaetalet_stack x =
+  appterm_of_stack (whd_betaetalet_state (x, empty_stack))
+let whd_betaetalet x = app_stack (whd_betaetalet_state (x,empty_stack))
+
+let whd_betalet_state = local_whd_state_gen betalet
+let whd_betalet_stack x = appterm_of_stack (whd_betalet_state (x, empty_stack))
+let whd_betalet x = app_stack (whd_betalet_state (x,empty_stack))
+
+(* 2. Delta Reduction Functions *)
+
+let whd_delta_state e = whd_state_gen delta e
+let whd_delta_stack env sigma x =
+  appterm_of_stack (whd_delta_state env sigma (x, empty_stack))
+let whd_delta env sigma c =
+  app_stack (whd_delta_state env sigma (c, empty_stack))
+
+let whd_betadelta_state e = whd_state_gen betadelta e
+let whd_betadelta_stack env sigma x =
+  appterm_of_stack (whd_betadelta_state env sigma (x, empty_stack))
+let whd_betadelta env sigma c =
+  app_stack (whd_betadelta_state env sigma (c, empty_stack))
+
+let whd_betaevar_state e = whd_state_gen betaevar e
+let whd_betaevar_stack env sigma c =
+  appterm_of_stack (whd_betaevar_state env sigma (c, empty_stack))
+let whd_betaevar env sigma c =
+  app_stack (whd_betaevar_state env sigma (c, empty_stack))
+
+
+let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e
+let whd_betadeltaeta_stack env sigma x =
+  appterm_of_stack (whd_betadeltaeta_state env sigma (x, empty_stack))
+let whd_betadeltaeta env sigma x = 
+  app_stack (whd_betadeltaeta_state env sigma (x, empty_stack))
+
+(* 3. Iota reduction Functions *)
+
+let whd_betaiota_state = local_whd_state_gen betaiota
+let whd_betaiota_stack x =
+  appterm_of_stack (whd_betaiota_state (x, empty_stack))
+let whd_betaiota x =
+  app_stack (whd_betaiota_state (x, empty_stack))
+
+let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
+let whd_betaiotazeta_stack x =
+  appterm_of_stack (whd_betaiotazeta_state (x, empty_stack))
+let whd_betaiotazeta x =
+  app_stack (whd_betaiotazeta_state (x, empty_stack))
+
+let whd_betaiotaevar_state e = whd_state_gen betaiotaevar e
+let whd_betaiotaevar_stack env sigma x =
+  appterm_of_stack (whd_betaiotaevar_state env sigma (x, empty_stack))
+let whd_betaiotaevar env sigma x = 
+  app_stack (whd_betaiotaevar_state env sigma (x, empty_stack))
+
+let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e
+let whd_betadeltaiota_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiota_state env sigma (x, empty_stack))
+let whd_betadeltaiota env sigma x = 
+  app_stack (whd_betadeltaiota_state env sigma (x, empty_stack))
+
+let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e
+let whd_betadeltaiotaeta_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack))
+let whd_betadeltaiotaeta env sigma x = 
+  app_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack))
+
+let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e
+let whd_betadeltaiota_nolet_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack))
+let whd_betadeltaiota_nolet env sigma x = 
+  app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack))
+
+(****************************************************************************)
+(*                   Reduction Functions                                    *)
+(****************************************************************************)
+
+(* Replacing defined evars for error messages *)
+let rec whd_evar sigma c =
+  match kind_of_term c with
+    | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev ->
+	whd_evar sigma (Instantiate.existential_value sigma (ev,args))
+    | _ -> collapse_appl c
+
+let nf_evar sigma =
+  local_strong (whd_evar sigma)
+
+(* lazy reduction functions. The infos must be created for each term *)
+let clos_norm_flags flgs env sigma t =
+  norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
+
+let nf_beta = clos_norm_flags Closure.beta empty_env Evd.empty
+let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty
+let nf_betadeltaiota env sigma =
+  clos_norm_flags Closure.betadeltaiota env sigma
+
+(* lazy weak head reduction functions *)
+let whd_flags flgs env sigma t =
+  whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
+
+(********************************************************************)
+(*                         Conversion                               *)
+(********************************************************************)
+(*
+let fkey = Profile.declare_profile "fhnf";;
+let fhnf info v = Profile.profile2 fkey fhnf info v;;
+
+let fakey = Profile.declare_profile "fhnf_apply";;
+let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
+*)
+
+(* Conversion utility functions *)
+
+type conversion_test = constraints -> constraints
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+let pb_is_equal pb = pb = CONV
+
+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 test_conversion f env sigma x y =
+  try let _ = f env (nf_evar sigma x) (nf_evar sigma y) in true
+  with NotConvertible -> false
+
+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
+
+(********************************************************************)
+(*             Special-Purpose Reduction                            *)
+(********************************************************************)
+
+let whd_meta metamap c = match kind_of_term c with
+  | Meta p -> (try List.assoc p metamap with Not_found -> c)
+  | _ -> c
+	
+(* Try to replace all metas. Does not replace metas in the metas' values
+ * Differs from (strong whd_meta). *)
+let plain_instance s c = 
+  let rec irec u = match kind_of_term u with
+    | Meta p -> (try List.assoc p s with Not_found -> u)
+    | App (f,l) when isCast f ->
+        let (f,t) = destCast f in
+        let l' = Array.map irec l in 
+        (match kind_of_term f with
+          | Meta p ->
+              (* Don't flatten application nodes: this is used to extract a
+                 proof-term from a proof-tree and we want to keep the structure
+                 of the proof-tree *)
+              (try let g = List.assoc p s in
+              match kind_of_term g with
+                | App _ -> 
+                    let h = id_of_string "H" in
+                    mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
+                | _ -> mkApp (g,l')
+              with Not_found -> mkApp (f,l'))
+          | _ -> mkApp (irec f,l'))
+    | Cast (m,_) when isMeta m ->
+	(try List.assoc (destMeta m) s with Not_found -> u)
+    | _ -> map_constr irec u
+  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)
+
+
+(* pseudo-reduction rule:
+ * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
+ * with an HNF on the first argument to produce a product.
+ * if this does not work, then we use the string S as part of our
+ * error message. *)
+
+let hnf_prod_app env sigma t n =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_prod_app: Need a product"
+
+let hnf_prod_appvect env sigma t nl = 
+  Array.fold_left (hnf_prod_app env sigma) t nl
+
+let hnf_prod_applist env sigma t nl = 
+  List.fold_left (hnf_prod_app env sigma) t nl
+				    
+let hnf_lam_app env sigma t n =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Lambda (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_lam_app: Need an abstraction"
+
+let hnf_lam_appvect env sigma t nl = 
+  Array.fold_left (hnf_lam_app env sigma) t nl
+
+let hnf_lam_applist env sigma t nl = 
+  List.fold_left (hnf_lam_app env sigma) t nl
+
+let splay_prod env sigma = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env sigma c in
+    match kind_of_term t with
+      | Prod (n,a,c0) ->
+	  decrec (push_rel (n,None,a) env)
+	    ((n,a)::m) c0
+      | _ -> m,t
+  in 
+  decrec env []
+
+let splay_prod_assum env sigma = 
+  let rec prodec_rec env l c =
+    let t = whd_betadeltaiota_nolet env sigma c in
+    match kind_of_term c with
+    | Prod (x,t,c)  ->
+	prodec_rec (push_rel (x,None,t) env)
+	  (Sign.add_rel_decl (x, None, t) l) c
+    | LetIn (x,b,t,c) ->
+	prodec_rec (push_rel (x, Some b, t) env)
+	  (Sign.add_rel_decl (x, Some b, t) l) c
+    | Cast (c,_)    -> prodec_rec env l c
+    | _               -> l,t
+  in
+  prodec_rec env Sign.empty_rel_context
+
+let splay_arity env sigma c =
+  let l, c = splay_prod env sigma c in
+  match kind_of_term c with
+    | Sort s -> l,s
+    | _ -> error "not an arity"
+
+let sort_of_arity env c = snd (splay_arity env Evd.empty c)
+  
+let decomp_n_prod env sigma n = 
+  let rec decrec env m ln c = if m = 0 then (ln,c) else 
+    match kind_of_term (whd_betadeltaiota env sigma c) with
+      | Prod (n,a,c0) ->
+	  decrec (push_rel (n,None,a) env)
+	    (m-1) (Sign.add_rel_decl (n,None,a) ln) c0
+      | _                      -> error "decomp_n_prod: Not enough products"
+  in 
+  decrec env n Sign.empty_rel_context
+
+(* One step of approximation *)
+
+let rec apprec env sigma 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)
+        else 
+	  s
+    | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with
+             | Reduced s -> apprec env sigma s
+	     | NotReducible -> s)
+    | _ -> s
+
+let hnf env sigma c = apprec env sigma (c, empty_stack)
+
+(* A reduction function like whd_betaiota but which keeps casts
+ * and does not reduce redexes containing existential variables.
+ * Used in Correctness.
+ * Added by JCF, 29/1/98. *)
+
+let whd_programs_stack env sigma = 
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | App (f,cl) ->
+	  let n = Array.length cl - 1 in
+	  let c = cl.(n) in
+	  if occur_existential c then 
+	    s 
+	  else 
+	    whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack)
+      | LetIn (_,b,_,c) ->
+	  if occur_existential b then
+	    s
+	  else
+	    stacklam whrec [b] c stack
+      | Lambda (_,_,c) ->
+          (match decomp_stack stack with
+             | None -> s
+             | Some (a,m) -> stacklam whrec [a] c m)
+      | Case (ci,p,d,lf) ->
+	  if occur_existential d then
+	    s
+	  else
+            let (c,cargs) = whrec (d, empty_stack) in
+            if reducible_mind_case c then
+	      whrec (reduce_mind_case
+		       {mP=p; mconstr=c; mcargs=list_of_stack cargs;
+			mci=ci; mlf=lf}, stack)
+	    else
+	      (mkCase (ci, p, app_stack(c,cargs), lf), stack)
+      | Fix fix ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+      | _ -> s
+  in 
+  whrec
+
+let whd_programs env sigma x =
+  app_stack (whd_programs_stack env sigma (x, empty_stack))
+
+exception IsType
+
+let find_conclusion env sigma =
+  let rec decrec env c =
+    let t = whd_betadeltaiota env sigma c in
+    match kind_of_term t with
+      | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | t -> t
+  in 
+  decrec env
+
+let is_arity env sigma c =
+  match find_conclusion env sigma c with
+    | Sort _ -> true
+    | _ -> false
+ 
+let info_arity env sigma c =
+  match find_conclusion env sigma c with
+    | Sort (Prop Null) -> false 
+    | Sort (Prop Pos) -> true 
+    | _ -> raise IsType
+    
+let is_info_arity env sigma c =
+  try (info_arity env sigma c) with IsType -> true
+  
+let is_type_arity env sigma c = 
+  match find_conclusion env sigma c with
+    | Sort (Type _) -> true
+    | _ -> false
+
+let is_info_type env sigma t =
+  let s = t.utj_type in
+  (s = Prop Pos) ||
+  (s <> Prop Null && 
+   try info_arity env sigma t.utj_val with IsType -> true)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
new file mode 100644
index 00000000..65cdd5cd
--- /dev/null
+++ b/pretyping/reductionops.mli
@@ -0,0 +1,190 @@
+(************************************************************************)
+(*  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: reductionops.mli,v 1.8.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Univ
+open Evd
+open Environ
+open Closure
+(*i*)
+
+(* Reduction Functions. *)
+
+exception Elimconst
+
+type state = constr * constr stack
+
+type contextual_reduction_function = env -> evar_map -> constr -> constr
+type reduction_function = contextual_reduction_function
+type local_reduction_function = constr -> constr
+
+type contextual_stack_reduction_function = 
+    env -> evar_map -> constr -> constr * constr list
+type stack_reduction_function = contextual_stack_reduction_function
+type local_stack_reduction_function = constr -> constr * constr list
+
+type contextual_state_reduction_function = 
+    env -> evar_map -> state -> state
+type state_reduction_function = contextual_state_reduction_function
+type local_state_reduction_function = state -> state
+
+(* Removes cast and put into applicative form *)
+val whd_stack : local_stack_reduction_function
+
+(* For compatibility: alias for whd\_stack *)
+val whd_castapp_stack : local_stack_reduction_function
+
+(*s Reduction Function Operators *)
+
+val strong : reduction_function -> reduction_function
+val local_strong : local_reduction_function -> local_reduction_function
+val strong_prodspine : local_reduction_function -> local_reduction_function
+(*i
+val stack_reduction_of_reduction : 
+  'a reduction_function -> 'a state_reduction_function
+i*)
+val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a 
+
+(*s Generic Optimized Reduction Function using Closures *)
+
+val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
+(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) 
+val nf_beta : local_reduction_function
+val nf_betaiota : local_reduction_function
+val nf_betadeltaiota : reduction_function
+val nf_evar : evar_map -> constr -> constr
+
+(* Lazy strategy, weak head reduction *)
+val whd_evar :  evar_map -> constr -> constr
+val whd_beta : local_reduction_function
+val whd_betaiota : local_reduction_function
+val whd_betaiotazeta : local_reduction_function
+val whd_betadeltaiota :  contextual_reduction_function
+val whd_betadeltaiota_nolet :  contextual_reduction_function
+val whd_betaetalet : local_reduction_function
+val whd_betalet : local_reduction_function
+
+val whd_beta_stack : local_stack_reduction_function
+val whd_betaiota_stack : local_stack_reduction_function
+val whd_betaiotazeta_stack : local_stack_reduction_function
+val whd_betadeltaiota_stack :  contextual_stack_reduction_function
+val whd_betadeltaiota_nolet_stack :  contextual_stack_reduction_function
+val whd_betaetalet_stack : local_stack_reduction_function
+val whd_betalet_stack : local_stack_reduction_function
+
+val whd_state : local_state_reduction_function
+val whd_beta_state : local_state_reduction_function
+val whd_betaiota_state : local_state_reduction_function
+val whd_betaiotazeta_state : local_state_reduction_function
+val whd_betadeltaiota_state :  contextual_state_reduction_function
+val whd_betadeltaiota_nolet_state :  contextual_state_reduction_function
+val whd_betaetalet_state : local_state_reduction_function
+val whd_betalet_state : local_state_reduction_function
+
+(*s Head normal forms *)
+
+val whd_delta_stack :  stack_reduction_function
+val whd_delta_state :  state_reduction_function
+val whd_delta :  reduction_function
+val whd_betadelta_stack :  stack_reduction_function
+val whd_betadelta_state :  state_reduction_function
+val whd_betadelta :  reduction_function
+val whd_betaevar_stack :  stack_reduction_function
+val whd_betaevar_state :  state_reduction_function
+val whd_betaevar :  reduction_function
+val whd_betaiotaevar_stack :  stack_reduction_function
+val whd_betaiotaevar_state :  state_reduction_function
+val whd_betaiotaevar :  reduction_function
+val whd_betadeltaeta_stack :  stack_reduction_function
+val whd_betadeltaeta_state :  state_reduction_function
+val whd_betadeltaeta :  reduction_function
+val whd_betadeltaiotaeta_stack :  stack_reduction_function
+val whd_betadeltaiotaeta_state :  state_reduction_function
+val whd_betadeltaiotaeta :  reduction_function
+
+val beta_applist : constr * constr list -> constr
+
+val hnf_prod_app     : env ->  evar_map -> constr -> constr -> constr
+val hnf_prod_appvect : env ->  evar_map -> constr -> constr array -> constr
+val hnf_prod_applist : env ->  evar_map -> constr -> constr list -> constr
+val hnf_lam_app      : env ->  evar_map -> constr -> constr -> constr
+val hnf_lam_appvect  : env ->  evar_map -> constr -> constr array -> constr
+val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
+
+val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
+val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
+val sort_of_arity : env -> constr -> sorts
+val decomp_n_prod : 
+  env ->  evar_map -> int -> constr -> Sign.rel_context * constr
+val splay_prod_assum :
+  env ->  evar_map -> constr -> Sign.rel_context * constr
+
+type 'a miota_args = {
+  mP      : constr;     (* the result type *)
+  mconstr : constr;     (* the constructor *)
+  mci     : case_info;  (* special info to re-build pattern *)
+  mcargs  : 'a list;    (* the constructor's arguments *)
+  mlf     : 'a array }  (* the branch code vector *)
+
+val reducible_mind_case : constr -> bool
+val reduce_mind_case : constr miota_args -> constr
+
+val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term
+val is_arity : env ->  evar_map -> constr -> bool
+val is_info_type : env ->  evar_map -> unsafe_type_judgment -> bool
+val is_info_arity : env ->  evar_map -> constr -> bool
+(*i Pour l'extraction
+val is_type_arity : env -> 'a evar_map -> constr -> bool
+val is_info_cast_type : env -> 'a evar_map -> constr -> bool
+val contents_of_cast_type : env -> 'a evar_map -> constr -> contents
+i*)
+
+val whd_programs :  reduction_function
+
+(* [reduce_fix] contracts a fix redex if it is actually reducible *)
+
+type fix_reduction_result = NotReducible | Reduced of state
+
+val fix_recarg : fixpoint -> constr stack -> (int * constr) option
+val reduce_fix : local_state_reduction_function -> fixpoint
+   -> constr stack -> fix_reduction_result
+
+(*s Conversion Functions (uses closures, lazy strategy) *)
+
+type conversion_test = constraints -> constraints
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+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
+
+(*s Special-Purpose Reduction Functions *)
+
+val whd_meta : (metavariable * constr) list -> constr -> constr
+val plain_instance : (metavariable * constr) list -> constr -> constr
+val instance : (metavariable * constr) list -> constr -> constr
+
+(*s Obsolete Reduction Functions *)
+
+(*i
+val hnf : env -> 'a evar_map -> constr -> constr * constr list
+i*)
+val apprec :  state_reduction_function
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
new file mode 100644
index 00000000..061382f7
--- /dev/null
+++ b/pretyping/retyping.ml
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: retyping.ml,v 1.43.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Term
+open Inductive
+open Names
+open Reductionops
+open Environ
+open Typeops
+open Declarations
+open Instantiate
+
+let outsort env sigma t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Sort s -> s
+    | _ -> anomaly "Retyping: found a type of type which is not a sort"
+
+let rec subst_type env sigma typ = function
+  | [] -> typ
+  | h::rest ->
+      match kind_of_term (whd_betadeltaiota env sigma typ) with
+        | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
+        | _ -> anomaly "Non-functional construction"
+
+(* Si ft est le type d'un terme f, lequel est appliqué à args, *)
+(* [sort_of_atomic_ty] calcule ft[args] qui doit être une sorte *)
+(* On suit une méthode paresseuse, en espèrant que ft est une arité *)
+(* et sinon on substitue *)
+
+let sort_of_atomic_type env sigma ft args =
+  let rec concl_of_arity env ar =
+    match kind_of_term (whd_betadeltaiota env sigma ar) with
+      | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
+      | Sort s -> s
+      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
+  in concl_of_arity env ft
+
+let typeur sigma metamap =
+  let rec type_of env cstr=
+    match kind_of_term cstr with
+    | Meta n ->
+          (try strip_outer_cast (List.assoc n metamap)
+           with Not_found -> anomaly "type_of: this is not a well-typed term")
+    | Rel n ->
+        let (_,_,ty) = lookup_rel n env in
+        lift n ty
+    | Var id ->
+        (try
+          let (_,_,ty) = lookup_named id env in
+          body_of_type ty
+        with Not_found ->
+          anomaly ("type_of: variable "^(string_of_id id)^" unbound"))
+    | Const c ->
+        let cb = lookup_constant c env in
+        body_of_type cb.const_type
+    | Evar ev -> existential_type sigma ev
+    | Ind ind -> body_of_type (type_of_inductive env ind)
+    | Construct cstr -> body_of_type (type_of_constructor env cstr)
+    | Case (_,p,c,lf) ->
+        let Inductiveops.IndType(_,realargs) =
+          try Inductiveops.find_rectype env sigma (type_of env c)
+          with Not_found -> anomaly "type_of: Bad recursive type" in
+        let t = whd_beta (applist (p, realargs)) in
+        (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
+          | Prod _ -> whd_beta (applist (t, [c]))
+          | _ -> t)
+    | Lambda (name,c1,c2) ->
+          mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+    | LetIn (name,b,c1,c2) ->
+         subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
+    | Fix ((_,i),(_,tys,_)) -> tys.(i)
+    | CoFix (i,(_,tys,_)) -> tys.(i)
+    | App(f,args)->
+        strip_outer_cast
+          (subst_type env sigma (type_of env f) (Array.to_list args))
+    | Cast (c,t) -> t
+    | Sort _ | Prod _ -> mkSort (sort_of env cstr)
+
+  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 (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
+	  | _, (Prop Null as s) -> s
+          | Prop _, (Prop Pos as s) -> s
+          | Type _, (Prop Pos as s) when
+              Environ.engagement env = Some ImpredicativeSet -> s
+          | Type _ as s, Prop Pos -> s
+	  | _, (Type u2 as s) -> s (*Type Univ.dummy_univ*))
+    | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
+    | Lambda _ | Fix _ | Construct _ ->
+        anomaly "sort_of: Not a type (1)"
+    | _ -> outsort env sigma (type_of env t)
+
+  and sort_family_of env t =
+    match kind_of_term t with
+    | Cast (c,s) when isSort s -> family_of_sort (destSort s)
+    | Sort (Prop c) -> InType
+    | Sort (Type u) -> InType
+    | Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2
+    | App(f,args) -> 
+       family_of_sort (sort_of_atomic_type env sigma (type_of env f) args)
+    | Lambda _ | Fix _ | Construct _ ->
+        anomaly "sort_of: Not a type (1)"
+    | _ -> family_of_sort (outsort env sigma (type_of env t))
+
+  in type_of, sort_of, sort_family_of
+
+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_type_of_with_meta env sigma metamap = 
+  let f,_,_ = typeur sigma metamap in f env
+
+(* Makes an assumption from a constr *)
+let get_assumption_of env evc c = c
+
+(* Makes an unsafe judgment from a constr *)
+let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
+
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
new file mode 100644
index 00000000..f29ac8d8
--- /dev/null
+++ b/pretyping/retyping.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  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: retyping.mli,v 1.16.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Evd
+open Environ
+open Pattern
+open Termops
+(*i*)
+
+(* This family of functions assumes its constr argument is known to be
+   well-typable. It does not type-check, just recompute the type
+   without any costly verifications. On non well-typable terms, it
+   either produces a wrong result or raise an anomaly. Use with care.
+   It doesn't handle predicative universes too. *)
+
+val get_type_of : env -> evar_map -> constr -> constr
+val get_sort_of : env -> evar_map -> types -> sorts
+val get_sort_family_of : env -> evar_map -> types -> sorts_family
+
+val get_type_of_with_meta : env -> evar_map -> metamap -> constr -> constr
+
+(* Makes an assumption from a constr *)
+val get_assumption_of : env -> evar_map -> constr -> types
+
+(* Makes an unsafe judgment from a constr *)
+val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
new file mode 100644
index 00000000..7e79a4fe
--- /dev/null
+++ b/pretyping/tacred.ml
@@ -0,0 +1,953 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: tacred.ml,v 1.75.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Libnames
+open Termops
+open Declarations
+open Inductive
+open Environ
+open Reductionops
+open Closure
+open Instantiate
+open Cbv
+open Rawterm
+
+exception Elimconst
+exception Redelimination
+
+let set_opaque_const = Conv_oracle.set_opaque_const
+let set_transparent_const sp =
+  let cb = Global.lookup_constant sp in
+  if cb.const_body <> None & cb.const_opaque then
+    errorlabstrm "set_transparent_const"
+      (str "Cannot make" ++ spc () ++ 
+         Nametab.pr_global_env Idset.empty (ConstRef sp) ++
+         spc () ++ str "transparent because it was declared opaque.");
+  Conv_oracle.set_transparent_const sp
+
+let set_opaque_var      = Conv_oracle.set_opaque_var
+let set_transparent_var = Conv_oracle.set_transparent_var
+
+let _ = 
+  Summary.declare_summary "Transparent constants and variables"
+    { Summary.freeze_function = Conv_oracle.freeze;
+      Summary.unfreeze_function = Conv_oracle.unfreeze;
+      Summary.init_function = Conv_oracle.init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let is_evaluable env ref =
+  match ref with
+      EvalConstRef kn ->
+        let (ids,kns) = Conv_oracle.freeze() in
+        KNpred.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
+
+type evaluable_reference =
+  | EvalConst of constant
+  | EvalVar of identifier
+  | EvalRel of int
+  | EvalEvar of existential
+
+let mkEvalRef = function
+  | EvalConst cst -> mkConst cst
+  | EvalVar id -> mkVar id
+  | EvalRel n -> mkRel n
+  | EvalEvar ev -> mkEvar ev
+
+let isEvalRef env c = match kind_of_term c with
+  | Const sp -> is_evaluable env (EvalConstRef sp)
+  | Var id -> is_evaluable env (EvalVarRef id)
+  | Rel _ | Evar _ -> true
+  | _ -> false
+
+let destEvalRef c = match kind_of_term c with
+  | Const cst ->  EvalConst cst
+  | Var id  -> EvalVar id
+  | Rel n -> EvalRel n
+  | Evar ev -> EvalEvar ev
+  | _ -> anomaly "Not an evaluable reference"
+
+let reference_opt_value sigma env = function
+  | EvalConst cst -> constant_opt_value env cst
+  | EvalVar id ->
+      let (_,v,_) = lookup_named id env in
+      v
+  | EvalRel n ->
+      let (_,v,_) = lookup_rel n env in
+      option_app (lift n) v
+  | EvalEvar ev -> existential_opt_value sigma ev
+
+exception NotEvaluable
+let reference_value sigma env c =
+  match reference_opt_value sigma env c with
+    | None -> raise NotEvaluable
+    | 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 *)
+
+type constant_evaluation = 
+  | EliminationFix of int * (int * (int * constr) list * int)
+  | EliminationMutualFix of
+      int * evaluable_reference *
+      (evaluable_reference option array * (int * (int * constr) list * int))
+  | EliminationCases of int
+  | NotAnElimination
+
+(* We use a cache registered as a global table *)
+
+
+module CstOrdered =
+  struct
+    type t = constant
+    let compare = Pervasives.compare
+  end
+module Cstmap = Map.Make(CstOrdered)
+
+let eval_table = ref Cstmap.empty
+
+type frozen = (int * constant_evaluation) Cstmap.t
+
+let init () =
+  eval_table := Cstmap.empty
+
+let freeze () =
+  !eval_table
+
+let unfreeze ct =
+  eval_table := ct
+
+let _ = 
+  Summary.declare_summary "evaluation"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+
+(* Check that c is an "elimination constant"
+   [xn:An]..[x1:A1](<P>MutCase (Rel i) of f1..fk end g1 ..gp)
+   or [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip)) 
+    with i1..ip distinct variables not occuring in t 
+   keep relevenant information ([i1,Ai1;..;ip,Aip],n,b)
+   with b = true in case of a fixpoint in order to compute 
+   an equivalent of Fix(f|t)[xi<-ai] as 
+   [yip:Bip]..[yi1:Bi1](F bn..b1) 
+   == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel 1)..(Rel p))
+   with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1] *)
+
+let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
+  let n = List.length labs in
+  let nargs = List.length args in
+  if nargs > n then raise Elimconst;
+  let nbfix = Array.length bds in
+  let li =
+    List.map
+      (function d -> match kind_of_term d with
+         | Rel k ->
+             if
+	       array_for_all (noccurn k) tys
+	       && array_for_all (noccurn (k+nbfix)) bds
+	     then 
+	       (k, List.nth labs (k-1)) 
+	     else 
+	       raise Elimconst
+         | _ -> 
+	     raise Elimconst) args
+  in
+  if list_distinct (List.map fst li) then 
+    let k = lv.(i) in
+    if k < nargs then
+(*  Such an optimisation would need eta-expansion 
+      let p = destRel (List.nth args k) in 
+      EliminationFix (n-p+1,(nbfix,li,n))
+*)
+      EliminationFix (n,(nbfix,li,n))
+    else
+      EliminationFix (n-nargs+lv.(i)+1,(nbfix,li,n))
+  else 
+    raise Elimconst
+
+(* Heuristic to look if global names are associated to other
+   components of a mutual fixpoint *)
+
+let invert_name labs l na0 env sigma ref = function
+  | Name id -> 
+      if na0 <> Name id then
+	let refi = match ref with
+	  | EvalRel _ | EvalEvar _ -> None
+	  | EvalVar id' -> Some (EvalVar id)
+	  | EvalConst kn ->
+	      let (mp,dp,_) = repr_kn kn in
+	      Some (EvalConst (make_kn mp dp (label_of_id id))) in
+	match refi with
+	  | None -> None
+	  | Some ref ->
+	      match reference_opt_value sigma env ref with
+		| None -> None
+		| Some c -> 
+		    let labs',ccl = decompose_lam c in
+		    let _, l' = whd_betalet_stack ccl in
+		    let labs' = List.map snd labs' in
+		    if labs' = labs & l = l' then Some ref else None
+      else Some ref
+  | Anonymous -> None (* Actually, should not occur *)
+
+(* [compute_consteval_direct] expand all constant in a whole, but
+   [compute_consteval_mutual_fix] only one by one, until finding the
+   last one before the Fix if the latter is mutually defined *)
+
+let compute_consteval_direct sigma env ref =
+  let rec srec env n labs c =
+    let c',l = whd_betadelta_stack env sigma c in
+    match kind_of_term c' with
+      | Lambda (id,t,g) when l=[] ->
+	  srec (push_rel (id,None,t) env) (n+1) (t::labs) g
+      | Fix fix ->
+	  (try check_fix_reversibility labs l fix 
+	  with Elimconst -> NotAnElimination)
+      | Case (_,_,d,_) when isRel d -> EliminationCases n
+      | _ -> NotAnElimination
+  in 
+  match reference_opt_value sigma env ref with
+    | None -> NotAnElimination
+    | Some c -> srec env 0 [] c
+
+let compute_consteval_mutual_fix sigma env ref =
+  let rec srec env minarg labs ref c =
+    let c',l = whd_betalet_stack c in
+    let nargs = List.length l in
+    match kind_of_term c' with
+      | Lambda (na,t,g) when l=[] ->
+	  srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
+      | Fix ((lv,i),(names,_,_) as fix) ->
+	  (* Last known constant wrapping Fix is ref = [labs](Fix l) *)
+	  (match compute_consteval_direct sigma env ref with
+	     | NotAnElimination -> (*Above const was eliminable but this not!*)
+		 NotAnElimination
+	     | EliminationFix (minarg',infos) ->
+		 let refs =
+		   Array.map
+		     (invert_name labs l names.(i) env sigma ref) names in
+		 let new_minarg = max (minarg'+minarg-nargs) minarg' in
+		 EliminationMutualFix (new_minarg,ref,(refs,infos))
+	     | _ -> assert false)
+      | _ when isEvalRef env c' ->
+	  (* Forget all \'s and args and do as if we had started with c' *)
+	  let ref = destEvalRef c' in
+	  (match reference_opt_value sigma env ref with
+	    | None -> anomaly "Should have been trapped by compute_direct"
+	    | Some c -> srec env (minarg-nargs) [] ref c)
+      | _ -> (* Should not occur *) NotAnElimination
+  in 
+  match reference_opt_value sigma env ref with
+    | None -> (* Should not occur *) NotAnElimination
+    | Some c -> srec env 0 [] ref c
+
+let compute_consteval sigma env ref =
+  match compute_consteval_direct sigma env ref with
+    | EliminationFix (_,(nbfix,_,_)) when nbfix <> 1 ->
+	compute_consteval_mutual_fix sigma env ref
+    | elim -> elim
+	
+let reference_eval sigma env = function
+  | EvalConst cst as ref -> 
+      (try
+	 Cstmap.find cst !eval_table
+       with Not_found -> begin
+	 let v = compute_consteval sigma env ref in
+	 eval_table := Cstmap.add cst v !eval_table;
+	 v
+       end)
+  | ref -> compute_consteval sigma env ref
+
+let rev_firstn_liftn fn ln = 
+  let rec rfprec p res l = 
+    if p = 0 then 
+      res 
+    else
+      match l with
+        | [] -> invalid_arg "Reduction.rev_firstn_liftn"
+        | a::rest -> rfprec (p-1) ((lift ln a)::res) rest
+  in 
+  rfprec fn []
+
+(*  EliminationFix ([(yi1,Ti1);...;(yip,Tip)],n) means f is some
+   [y1:T1,...,yn:Tn](Fix(..) yi1 ... yip);
+   f is applied to largs and we need for recursive calls to build
+   [x1:Ti1',...,xp:Tip'](f a1..a(n-p) yi1 ... yip) 
+   where a1...an are the n first arguments of largs and Tik' is Tik[yil=al]
+   To check ... *)
+
+let make_elim_fun (names,(nbfix,lv,n)) largs =
+  let labs = list_firstn n (list_of_stack largs) in
+  let p = List.length lv in
+  let ylv = List.map fst lv in
+  let la' = list_map_i 
+	      (fun q aq ->
+		 try (mkRel (p+1-(list_index (n-q) ylv))) 
+		 with Not_found -> aq) 0
+              (List.map (lift p) labs) 
+  in 
+  fun i ->
+    match names.(i) with
+      | None -> None
+      | Some ref -> Some (
+(*    let fi =
+      if nbfix = 1 then
+	mkEvalRef ref
+      else
+	match ref with
+	  | EvalConst (sp,args) ->
+	      mkConst (make_path (dirpath sp) id (kind_of_path sp),args)
+	  | _ -> anomaly "elimination of local fixpoints not implemented"
+    in
+*)
+      list_fold_left_i 
+	(fun i c (k,a) -> 
+	   mkLambda (Name(id_of_string"x"),
+		     substl (rev_firstn_liftn (n-k) (-i) la') a,
+		     c))
+	0 (applistc (mkEvalRef ref) la') lv)
+
+(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make 
+   the reduction using this extra information *)
+
+let contract_fix_use_function f
+  ((recindices,bodynum),(types,names,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)
+
+let reduce_fix_use_function f whfun fix stack =
+  match fix_recarg fix stack with
+    | None -> NotReducible
+    | Some (recargnum,recarg) ->
+        let (recarg'hd,_ as recarg') =
+	  if isRel recarg then
+	    (* The recarg cannot be a local def, no worry about the right env *)
+	    (recarg, empty_stack) 
+	  else
+	    whfun (recarg, empty_stack) in
+        let stack' = stack_assign stack recargnum (app_stack recarg') in
+	(match kind_of_term recarg'hd with
+           | Construct _ ->
+	       Reduced (contract_fix_use_function f fix,stack')
+	   | _ -> NotReducible)
+
+let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) =
+  let nbodies = Array.length bodies in
+  let make_Fi j = match f j with
+    | None -> mkCoFix(j,typedbodies)
+    | Some c -> c in
+(*    match List.nth names j with Name id -> f id | _ -> assert false in*)
+  let subbodies = list_tabulate make_Fi nbodies in
+  substl subbodies bodies.(bodynum)
+
+let reduce_mind_case_use_function func env mia =
+  match kind_of_term mia.mconstr with 
+    | Construct(ind_sp,i as cstr_sp) ->
+	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
+	applist (mia.mlf.(i-1), real_cargs)
+    | CoFix (_,(names,_,_) as cofix) ->
+	let build_fix_name i =
+	  match names.(i) with 
+	    | Name id ->
+                if isConst func then
+		  let (mp,dp,_) = repr_kn (destConst func) in
+		  let kn = make_kn mp dp (label_of_id id) in
+		  (match constant_opt_value env kn with
+		    | None -> None
+		    | Some _ -> Some (mkConst kn))
+                else None
+	    | Anonymous -> None in 
+	let cofix_def = contract_cofix_use_function build_fix_name cofix in
+	mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf)
+    | _ -> assert false
+
+let special_red_case sigma env whfun (ci, p, c, lf)  =
+  let rec redrec s = 
+    let (constr, cargs) = whfun s in 
+    if isEvalRef env constr then
+      let ref = destEvalRef constr in
+      match reference_opt_value sigma env ref with
+        | None -> raise Redelimination
+        | Some gvalue ->
+	    if reducible_mind_case gvalue then
+	      reduce_mind_case_use_function constr env
+	        {mP=p; mconstr=gvalue; mcargs=list_of_stack cargs;
+                mci=ci; mlf=lf}
+	    else
+	      redrec (gvalue, cargs)
+    else
+      if reducible_mind_case constr then
+        reduce_mind_case
+	  {mP=p; mconstr=constr; mcargs=list_of_stack cargs;
+	  mci=ci; mlf=lf}
+      else 
+	raise Redelimination
+  in 
+  redrec (c, empty_stack)
+
+
+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)
+    | 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
+	   | NotReducible -> raise Redelimination
+	   | Reduced (c,rest) -> (nf_beta c, rest))
+    | EliminationMutualFix (min,refgoal,refinfos)
+	when stack_args_size largs >= min ->
+	let rec descend ref args =
+	  let c = reference_value sigma env ref in
+	  if ref = refgoal then
+	    (c,args)
+	  else
+	    let c', lrest = whd_betalet_state (c,args) in
+	    descend (destEvalRef c') lrest in
+	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
+	   | NotReducible -> raise Redelimination
+	   | Reduced (c,rest) -> (nf_beta c, rest))
+    | _ -> raise Redelimination
+
+and construct_const env sigma = 
+  let rec hnfstack (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) ->
+          (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
+      | 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)
+      | _ when isEvalRef env x ->
+	  let ref = destEvalRef x in
+          (try
+	    hnfstack (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
+  in 
+  hnfstack 
+
+(************************************************************************)
+(*            Special Purpose Reduction Strategies                     *)
+
+(* Red reduction tactic: reduction to a product *)
+
+let internal_red_product env sigma c = 
+  let simpfun = clos_norm_flags betaiotazeta env sigma in
+  let rec redrec env x =
+    match kind_of_term x with
+      | App (f,l) -> 
+          (match kind_of_term f with
+             | Fix fix ->
+                 let stack = append_stack l empty_stack in
+                 (match fix_recarg fix stack with
+                    | None -> raise Redelimination
+                    | Some (recargnum,recarg) ->
+                        let recarg' = redrec env recarg in
+                        let stack' = stack_assign stack recargnum recarg' in
+                        simpfun (app_stack (f,stack')))
+             | _ -> simpfun (appvect (redrec env f, l)))
+      | Cast (c,_) -> redrec env c
+      | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
+      | LetIn (x,a,b,t) -> redrec env (subst1 a t)
+      | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
+      | _ when isEvalRef env x -> 
+          (* TO DO: re-fold fixpoints after expansion *)
+          (* to get true one-step reductions *)
+          let ref = destEvalRef x in
+	  (match reference_opt_value sigma env ref with
+	     | None -> raise Redelimination
+	     | Some c -> c)
+      | _ -> raise Redelimination
+  in redrec env c
+
+let red_product env sigma c = 
+  try internal_red_product env sigma c
+  with Redelimination -> error "Not reducible"
+
+(* Hnf reduction tactic: *)
+
+let hnf_constr env sigma c = 
+  let rec redrec (x, largs 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) ->
+          (try
+             redrec 
+	       (special_red_case sigma env (whd_betadeltaiota_state env sigma) 
+		  (ci, p, c, lf), largs)
+           with Redelimination -> 
+	     app_stack s)
+      | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
+             | Reduced s' -> redrec s'
+	     | NotReducible -> app_stack 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)
+           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)
+
+(* Simpl reduction tactic: same as simplify, but also reduces
+   elimination constants *)
+
+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 nf env sigma c = strong whd_nf env sigma c
+
+let is_reference c = 
+  try let r = reference_of_constr c in true with _ -> false
+
+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 maxocc = List.fold_right max locs 0 in
+  let pos = ref 1 in
+  let check = ref true 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
+    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
+      incr pos;
+      if ok then
+	f env sigma t
+      else if byhead then
+	(* find other occurrences of c in t; TODO: ensure left-to-right *)
+        let (f,l) = destApplication t in
+	mkApp (f, array_map_left (traverse envc) l)
+      else
+	t
+    else
+      map_constr_with_binders_left_to_right
+	(fun d (env,c) -> (push_rel d env,lift 1 c))
+        traverse envc t
+  in
+  let t' = traverse (env,c) t in
+  if locs <> [] & List.exists (fun o -> o >= !pos or o <= - !pos) locs then
+    errorlabstrm "contextually" (str "Too few occurences");
+  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_kn 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
+	let (n1,ol1,p') = substlin env name n ol p in  (* ATTENTION ERREUR *)
+        (match ol1 with                                 (* si P pas affiche *)
+           | [] -> (n1,[],mkCase (ci, p', d, llf))
+           | _  ->
+               let (n2,ol2,d') = substlin env name n1 ol1 d 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,c2)   ->
+        let (n1,ol1,c1') = substlin env name n ol c1 in
+        (match ol1 with 
+           | [] -> (n1,[],mkCast (c1',c2))
+           | _  ->
+               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+               (n2,ol2,mkCast (c1',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 string_of_evaluable_ref env = function
+  | EvalVarRef id -> string_of_id id
+  | EvalConstRef kn ->
+      string_of_qualid 
+        (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn))
+
+let unfold env sigma name =
+  if is_evaluable env name then
+    clos_norm_flags (unfold_red name) env sigma
+  else
+    error (string_of_evaluable_ref env name^" is opaque")
+
+(* [unfoldoccs : (readable_constraints -> (int list * section_path) -> constr -> constr)]
+ * Unfolds the constant name in a term c following a list of occurrences occl.
+ * at the occurrences of occ_list. If occ_list is empty, unfold all occurences.
+ * 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")
+          | _ -> error ("bad occurrence numbers of "
+			^(string_of_evaluable_ref env name))
+
+(* Unfold reduction tactic: *)
+let unfoldn loccname env sigma c = 
+  List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname
+
+(* Re-folding constants tactics: refold com in term c *)
+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)
+
+let fold_commands cl env sigma c =
+  List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c
+
+
+(* call by value reduction functions *)
+let cbv_norm_flags flags env sigma t =
+  cbv_norm (create_cbv_infos flags env) (nf_evar sigma t)
+
+let cbv_beta = cbv_norm_flags beta empty_env Evd.empty
+let cbv_betaiota = cbv_norm_flags betaiota empty_env Evd.empty
+let cbv_betadeltaiota env sigma =  cbv_norm_flags betadeltaiota env sigma
+
+let compute = cbv_betadeltaiota
+
+(* Pattern *)
+
+(* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only
+ * the specified occurrences. *)
+
+let abstract_scheme env sigma (locc,a) t =
+  let ta = Retyping.get_type_of env sigma a in
+  let na = named_hd env ta Anonymous in
+  if occur_meta ta then error "cannot find a type for the generalisation";
+  if occur_meta a then 
+    mkLambda (na,ta,t)
+  else 
+    mkLambda (na, ta,subst_term_occ locc a t)
+
+
+let pattern_occs loccs_trm env sigma c =
+  let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in
+  applist(abstr_trm, List.map snd loccs_trm)
+
+(* Generic reduction: reduction functions used in reduction tactics *)
+
+type red_expr = (constr, evaluable_global_reference) red_expr_gen
+
+open RedFlags
+
+let make_flag_constant = function
+  | EvalVarRef id -> fVAR id
+  | EvalConstRef sp -> fCONST sp
+
+let make_flag f =
+  let red = no_red in
+  let red = if f.rBeta then red_add red fBETA else red in
+  let red = if f.rIota then red_add red fIOTA else red in
+  let red = if f.rZeta then red_add red fZETA else red in
+  let red =
+    if f.rDelta then (* All but rConst *)
+        let red = red_add red fDELTA in
+        let red = red_add_transparent red (Conv_oracle.freeze ()) in
+	List.fold_right
+	  (fun v red -> red_sub red (make_flag_constant v))
+	  f.rConst red
+    else (* Only rConst *)
+        let red = red_add_transparent (red_add red fDELTA) all_opaque in
+	List.fold_right
+	  (fun v red -> red_add red (make_flag_constant v))
+	  f.rConst red
+  in red
+
+let red_expr_tab = ref Stringmap.empty
+
+let declare_red_expr s f =
+  try 
+    let _ = Stringmap.find s !red_expr_tab in
+    error ("There is already a reduction expression of name "^s)
+  with Not_found ->
+    red_expr_tab := Stringmap.add s f !red_expr_tab
+
+let reduction_of_redexp = function
+  | Red internal -> if internal then internal_red_product else red_product
+  | Hnf -> hnf_constr
+  | Simpl (Some (_,c as lp)) -> contextually (is_reference c) lp nf
+  | Simpl None -> nf
+  | Cbv f -> cbv_norm_flags (make_flag f)
+  | Lazy f -> clos_norm_flags (make_flag f)
+  | Unfold ubinds -> unfoldn ubinds
+  | Fold cl -> fold_commands cl
+  | Pattern lp -> pattern_occs lp
+  | ExtraRedExpr (s,c) ->
+      (try Stringmap.find s !red_expr_tab
+      with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+(* Used in several tactics. *)
+
+exception NotStepReducible
+
+let one_step_reduce env sigma c = 
+  let rec redrec (x, largs as s) =
+    match kind_of_term x with
+      | Lambda (n,t,c)  ->
+          (match decomp_stack largs 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)
+      | Case (ci,p,c,lf) ->
+          (try
+	     (special_red_case sigma env (whd_betadeltaiota_state env sigma)
+	       (ci,p,c,lf), largs)
+           with Redelimination -> raise NotStepReducible)
+      | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs 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
+          (try
+            red_elim_const env sigma ref largs
+           with Redelimination ->
+	     match reference_opt_value sigma env ref with
+	       | Some d -> d, largs
+	       | 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 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 rec elimrec env t l = 
+    let c, _ = Reductionops.whd_stack t in
+    match kind_of_term c with
+      | Prod (n,ty,t') ->
+	  if allow_product then
+	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+	  else 
+	     errorlabstrm "Tactics.reduce_to_ref_gen"
+	       (str"Not an induction object of atomic type")
+      | _ ->
+	  try 
+	    if reference_of_constr c = ref 
+	    then it_mkProd_or_LetIn t l
+	    else raise Not_found
+	  with Not_found ->
+          try 
+	    let t' = nf_betaiota (one_step_reduce env sigma t) in 
+	    elimrec env t' l
+          with NotStepReducible -> raise Not_found
+  in
+  elimrec env t []
+
+let reduce_to_quantified_ref = reduce_to_ref_gen true
+let reduce_to_atomic_ref = reduce_to_ref_gen false
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
new file mode 100644
index 00000000..162275d5
--- /dev/null
+++ b/pretyping/tacred.mli
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  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: tacred.mli,v 1.21.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Evd
+open Reductionops
+open Closure
+open Rawterm
+(*i*)
+
+(*s Reduction functions associated to tactics. \label{tacred} *)
+
+val is_evaluable : env -> evaluable_global_reference -> bool
+
+exception Redelimination
+
+(* Red (raise Redelimination if nothing reducible) *)
+val red_product : reduction_function
+
+(* Hnf *)
+val hnf_constr :  reduction_function
+
+(* Simpl *)
+val nf :  reduction_function
+
+(* Unfold *)
+val unfoldn : 
+  (int list * evaluable_global_reference) list ->  reduction_function
+
+(* Fold *)
+val fold_commands : constr list ->  reduction_function
+
+(* Pattern *)
+val pattern_occs : (int list * constr) list ->  reduction_function
+(* Rem: Lazy strategies are defined in Reduction *)
+
+(* Call by value strategy (uses Closures) *)
+val cbv_norm_flags : Closure.RedFlags.reds ->  reduction_function
+  val cbv_beta : local_reduction_function
+  val cbv_betaiota : local_reduction_function
+  val cbv_betadeltaiota :  reduction_function
+  val compute :  reduction_function  (* = [cbv_betadeltaiota] *)
+
+(* [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)]
+   with [I] an inductive definition;
+   returns [I] and [t'] or fails with a user error *)
+val reduce_to_atomic_ind : env ->  evar_map -> types -> inductive * types
+
+(* [reduce_to_quantified_ind env sigma t] puts [t] in the form
+   [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition;
+   returns [I] and [t'] or fails with a user error *)
+val reduce_to_quantified_ind : env ->  evar_map -> types -> inductive * types
+
+(* [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
+   [t'=(x1:A1)..(xn:An)(ref args)] and raise Not_found if not possible *)
+val reduce_to_quantified_ref :
+  env ->  evar_map -> Libnames.global_reference -> types -> types
+
+val reduce_to_atomic_ref :
+  env ->  evar_map -> Libnames.global_reference -> types -> types
+
+type red_expr = (constr, evaluable_global_reference) red_expr_gen
+
+val contextually : bool -> constr occurrences -> reduction_function
+  -> reduction_function
+val reduction_of_redexp : red_expr -> reduction_function
+
+val declare_red_expr : string -> reduction_function -> unit
+
+(* Opaque and Transparent commands. *)
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
+
+val set_opaque_var      : identifier -> unit
+val set_transparent_var : identifier -> unit
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
new file mode 100644
index 00000000..8f12ca62
--- /dev/null
+++ b/pretyping/termops.ml
@@ -0,0 +1,938 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: termops.ml,v 1.29.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Sign
+open Environ
+open Libnames
+open Nametab
+
+(* Sorts and sort family *)
+
+let print_sort = function
+  | Prop Pos -> (str "Set")
+  | Prop Null -> (str "Prop")
+  | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")")
+
+let print_sort_family = function
+  | InSet -> (str "Set")
+  | InProp -> (str "Prop")
+  | InType -> (str "Type")
+
+let pr_name = function
+  | Name id -> pr_id id
+  | Anonymous -> str "_"
+
+let pr_sp sp = str(string_of_kn sp)
+
+let rec print_constr c = match kind_of_term c with
+  | Rel n -> str "#"++int n
+  | Meta n -> str "Meta(" ++ int n ++ str ")"
+  | Var id -> pr_id id
+  | Sort s -> print_sort s
+  | Cast (c,t) -> hov 1 
+      (str"(" ++ print_constr c ++ cut() ++
+       str":" ++ print_constr t ++ str")")
+  | Prod (Name(id),t,c) -> hov 1
+      (str"forall " ++ pr_id id ++ str":" ++ print_constr t ++ str"," ++
+       spc() ++ print_constr c)
+  | Prod (Anonymous,t,c) -> hov 0
+      (str"(" ++ print_constr t ++ str " ->" ++ spc() ++
+       print_constr c ++ str")")
+  | Lambda (na,t,c) -> hov 1
+      (str"fun " ++ pr_name na ++ str":" ++
+       print_constr t ++ str" =>" ++ spc() ++ print_constr c)
+  | LetIn (na,b,t,c) -> hov 0
+      (str"let " ++ pr_name na ++ str":=" ++ print_constr b ++
+       str":" ++ brk(1,2) ++ print_constr t ++ cut() ++
+       print_constr c)
+  | App (c,l) ->  hov 1
+      (str"(" ++ print_constr c ++ spc() ++
+       prlist_with_sep spc print_constr (Array.to_list l) ++ str")")
+  | Evar (e,l) -> hov 1
+      (str"Evar#" ++ int e ++ str"{" ++
+       prlist_with_sep spc print_constr (Array.to_list l) ++str"}")
+  | Const c -> str"Cst(" ++ pr_sp c ++ str")"
+  | Ind (sp,i) -> str"Ind(" ++ pr_sp sp ++ str"," ++ int i ++ str")"
+  | Construct ((sp,i),j) ->
+      str"Constr(" ++ pr_sp sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
+  | Case (ci,p,c,bl) -> v 0
+      (hv 0 (str"<"++print_constr p++str">"++ cut() ++ str"Case " ++
+             print_constr c ++ str"of") ++ cut() ++
+       prlist_with_sep (fun _ -> brk(1,2)) print_constr (Array.to_list bl) ++
+      cut() ++ str"end")
+  | Fix ((t,i),(lna,tl,bl)) ->
+      let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
+      hov 1
+        (str"fix " ++ int i ++ spc() ++  str"{" ++
+         v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
+           pr_name na ++ str"/" ++ int i ++ str":" ++ print_constr ty ++
+           cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+         str"}")
+  | CoFix(i,(lna,tl,bl)) ->
+      let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
+      hov 1
+        (str"cofix " ++ int i ++ spc() ++  str"{" ++
+         v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
+           pr_name na ++ str":" ++ print_constr ty ++
+           cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+         str"}")
+
+(*let current_module = ref empty_dirpath
+
+let set_module m = current_module := m*)
+
+let new_univ = 
+  let univ_gen = ref 0 in
+  (fun sp ->
+    incr univ_gen; 
+    Univ.make_univ (Lib.library_dp(),!univ_gen))
+
+let new_sort_in_family = function 
+  | InProp -> mk_Prop
+  | InSet -> mk_Set
+  | InType -> Type (new_univ ())
+
+
+
+(* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *)
+let prod_it ~init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
+
+(* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *)
+let lam_it ~init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init
+
+(* [Rel (n+m);...;Rel(n+1)] *)
+let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
+
+let rel_list n m = 
+  let rec reln l p = 
+    if p>m then l else reln (mkRel(n+p)::l) (p+1)
+  in 
+  reln [] 1
+
+(* Same as [rel_list] but takes a context as argument and skips let-ins *)
+let extended_rel_list n hyps =
+  let rec reln l p = function
+    | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
+    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | [] -> l
+  in 
+  reln [] 1 hyps
+
+let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
+
+
+
+let push_rel_assum (x,t) env = push_rel (x,None,t) env
+
+let push_rels_assum assums =
+  push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums)
+
+let push_named_rec_types (lna,typarray,_) env =
+  let ctxt =
+    array_map2_i
+      (fun i na t ->
+	 match na with
+	   | Name id -> (id, None, type_app (lift i) t)
+	   | Anonymous -> anomaly "Fix declarations must be named")
+      lna typarray in
+  Array.fold_left
+    (fun e assum -> push_named assum e) env ctxt
+
+let rec lookup_rel_id id sign = 
+  let rec lookrec = function
+    | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l)
+    | (n, (Name id',_,t)::l)  -> if id' = id then (n,t) else lookrec (n+1,l)
+    | (_, [])                 -> raise Not_found
+  in 
+  lookrec (1,sign)
+
+(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+let mkProd_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
+
+(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
+let mkProd_wo_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na,  t, c)
+    | Some b -> subst1 b c
+
+let it_mkProd_wo_LetIn ~init = 
+  List.fold_left (fun c d -> mkProd_wo_LetIn d c) init
+
+let it_mkProd_or_LetIn ~init = 
+  List.fold_left (fun c d -> mkProd_or_LetIn d c) init
+
+let it_mkLambda_or_LetIn ~init =
+  List.fold_left (fun c d -> mkLambda_or_LetIn d c) init
+
+let it_named_context_quantifier f ~init = 
+  List.fold_left (fun c d -> f d c) init
+
+let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn
+let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
+
+(* *)
+
+(* strips head casts and flattens head applications *)
+let rec strip_head_cast c = match kind_of_term c with
+  | App (f,cl) -> 
+      let rec collapse_rec f cl2 = match kind_of_term f with
+	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
+	| Cast (c,_) -> collapse_rec c cl2
+	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
+      in 
+      collapse_rec f cl
+  | Cast (c,t) -> strip_head_cast c
+  | _ -> c
+
+(* [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
+   [l]) at each binder traversal (with name [na]); it is not recursive
+   and the order with which subterms are processed is not specified *)
+
+let map_constr_with_named_binders g f l c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (c,t) -> mkCast (f l c, f l t)
+  | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c)
+  | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
+  | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
+  | App (c,al) -> mkApp (f l c, Array.map (f l) al)
+  | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
+  | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      let l' = Array.fold_left (fun l na -> g na l) l lna in
+      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let l' = Array.fold_left (fun l na -> g na l) l lna in
+      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+
+(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the
+   immediate subterms of [c]; it carries an extra data [n] (typically
+   a lift index) which is processed by [g] (which typically add 1 to
+   [n]) at each binder traversal; the subterms are processed from left
+   to right according to the usual representation of the constructions
+   (this may matter if [f] does a side-effect); it is not recursive;
+   in fact, the usual representation of the constructions is at the
+   time being almost those of the ML representation (except for
+   (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 map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (c,t) -> let c' = f l c in mkCast (c', f l t)
+  | Prod (na,t,c) ->
+      let t' = f l t in
+      mkProd (na, t', f (g (na,None,t) l) c)
+  | Lambda (na,t,c) ->
+      let t' = f l t in
+      mkLambda (na, t', f (g (na,None,t) l) c)
+  | LetIn (na,b,t,c) ->
+      let b' = f l b in
+      let t' = f l t in
+      let c' = f (g (na,Some b,t) l) c in
+      mkLetIn (na, b', t', c')
+  | App (c,[||]) -> assert false
+  | App (c,al) ->
+      (*Special treatment to be able to recognize partially applied subterms*)
+      let a = al.(Array.length al - 1) in
+      let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in
+      mkApp (hd, [| f l a |])
+  | Evar (e,al) -> mkEvar (e, array_map_left (f l) al)
+  | Case (ci,p,c,bl) ->
+      let p' = f l p in let c' = f l c in
+      mkCase (ci, p', c', array_map_left (f l) bl)
+  | Fix (ln,(lna,tl,bl as fx)) ->
+      let l' = fold_rec_types g fx l in
+      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
+      mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl as fx)) ->
+      let l' = fold_rec_types g fx l in
+      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
+      mkCoFix (ln,(lna,tl',bl'))
+
+(* strong *)
+let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> cstr
+  | Cast (c,t) -> 
+      let c' = f l c in
+      let t' = f l t in
+      if c==c' && t==t' then cstr else mkCast (c', t')
+  | Prod (na,t,c) ->
+      let t' = f l t in
+      let c' = f (g (na,None,t) l) c in
+      if t==t' && c==c' then cstr else mkProd (na, t', c')
+  | Lambda (na,t,c) ->
+      let t' = f l t in
+      let c' = f (g (na,None,t) l) c in
+      if t==t' && c==c' then cstr else  mkLambda (na, t', c')
+  | LetIn (na,b,t,c) ->
+      let b' = f l b in
+      let t' = f l t in
+      let c' = f (g (na,Some b,t) l) c in
+      if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')
+  | App (c,al) ->
+      let c' = f l c in
+      let al' = Array.map (f l) al in
+      if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al')
+  | Evar (e,al) ->
+      let al' = Array.map (f l) al in
+      if array_for_all2 (==) al al' then cstr else mkEvar (e, al')
+  | Case (ci,p,c,bl) ->
+      let p' = f l p in
+      let c' = f l c in
+      let bl' = Array.map (f l) bl in
+      if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else
+        mkCase (ci, p', c', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let tl' = Array.map (f l) tl in
+      let l' =
+        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let bl' = Array.map (f l') bl in
+      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      then cstr
+      else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let tl' = Array.map (f l) tl in
+      let l' =
+        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let bl' = Array.map (f l') bl in
+      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      then cstr
+      else mkCoFix (ln,(lna,tl',bl'))
+
+(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
+   subterms of [c] starting from [acc] and proceeding from left to
+   right according to the usual representation of the constructions as
+   [fold_constr] but it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive *)
+
+let fold_constr_with_binders g f n acc c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> acc
+  | Cast (c,t) -> f n (f n acc c) t
+  | Prod (_,t,c) -> f (g n) (f n acc t) c
+  | Lambda (_,t,c) -> f (g n) (f n acc t) c
+  | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c
+  | App (c,l) -> Array.fold_left (f n) (f n acc c) l
+  | Evar (_,l) -> Array.fold_left (f n) acc l
+  | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
+  | Fix (_,(lna,tl,bl)) -> 
+      let n' = iterate g (Array.length tl) n in
+      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd
+  | CoFix (_,(lna,tl,bl)) ->
+      let n' = iterate g (Array.length tl) n in
+      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd
+
+(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate
+   subterms of [c]; it carries an extra data [acc] which is processed by [g] at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let iter_constr_with_full_binders g f l c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,t) -> f l c; f l t
+  | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
+  | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
+  | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
+  | App (c,args) -> f l c; Array.iter (f l) args
+  | Evar (_,args) -> Array.iter (f l) args
+  | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl
+  | Fix (_,(lna,tl,bl)) -> 
+      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      Array.iter (f l) tl;
+      Array.iter (f l') bl
+  | CoFix (_,(lna,tl,bl)) ->
+      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      Array.iter (f l) tl;
+      Array.iter (f l') bl
+
+(***************************)
+(* occurs check functions  *)                         
+(***************************)
+
+exception Occur
+
+let occur_meta c =
+  let rec occrec c = match kind_of_term c with
+    | Meta _ -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur -> true
+
+let occur_existential c = 
+  let rec occrec c = match kind_of_term c with
+    | Evar _ -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur -> true
+
+let occur_const s c = 
+  let rec occur_rec c = match kind_of_term c with
+    | Const sp when sp=s -> raise Occur
+    | _ -> iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_evar n c = 
+  let rec occur_rec c = match kind_of_term c with
+    | Evar (sp,_) when sp=n -> raise Occur
+    | _ -> iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_in_global env id constr =
+  let vars = vars_of_global env constr in
+  if List.mem id vars then raise Occur
+
+let occur_var env s c = 
+  let rec occur_rec c =
+    occur_in_global env s c;
+    iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_var_in_decl env hyp (_,c,typ) =
+  match c with
+    | None -> occur_var env hyp typ
+    | Some body ->
+        occur_var env hyp typ ||
+        occur_var env hyp body
+
+(* Tests that t is a subterm of c *)
+let occur_term t c = 
+  let eq_constr_fail c = if eq_constr t c then raise Occur
+  in let rec occur_rec c = eq_constr_fail c; iter_constr occur_rec c
+  in try occur_rec c; false with Occur -> true
+
+(* returns the list of free debruijn indices in a term *)
+
+let free_rels m = 
+  let rec frec depth acc c = match kind_of_term c with
+    | Rel n       -> if n >= depth then Intset.add (n-depth+1) acc else acc
+    | _ -> fold_constr_with_binders succ frec depth acc c
+  in 
+  frec 1 Intset.empty m
+
+
+(* (dependent M N) is true iff M is eq_term with a subterm of N 
+   M is appropriately lifted through abstractions of N *)
+
+let dependent m t =
+  let rec deprec m t =
+    if eq_constr m t then
+      raise Occur
+    else
+      match kind_of_term m, kind_of_term t with
+	| App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
+	    deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
+	    Array.iter (deprec m)
+	      (Array.sub lt 
+		(Array.length lm) ((Array.length lt) - (Array.length lm)))
+	| _ -> iter_constr_with_binders (lift 1) deprec m t
+  in 
+  try deprec m t; false with Occur -> true
+
+let pop t = lift (-1) t
+
+(***************************)
+(*  bindings functions *)                         
+(***************************)
+
+type metamap = (metavariable * constr) list 
+
+let rec subst_meta bl c = 
+  match kind_of_term c with
+    | Meta i -> (try List.assoc i bl with Not_found -> c)
+    | _ -> map_constr (subst_meta bl) c
+
+(* First utilities for avoiding telescope computation for subst_term *)
+
+let prefix_application eq_fun (k,c) (t : constr) = 
+  let c' = collapse_appl c and t' = collapse_appl t in
+  match kind_of_term c', kind_of_term t' with
+    | App (f1,cl1), App (f2,cl2) ->
+	let l1 = Array.length cl1
+	and l2 = Array.length cl2 in
+	if l1 <= l2
+	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
+	  Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1)))
+	else 
+	  None
+    | _ -> None
+
+let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = 
+  let c' = collapse_appl c and t' = collapse_appl t in
+  match kind_of_term c', kind_of_term t' with
+    | App (f1,cl1), App (f2,cl2) ->
+	let l1 = Array.length cl1
+	and l2 = Array.length cl2 in
+	if l1 <= l2
+	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
+	  Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1)))
+	else 
+	  None
+    | _ -> None
+
+(* Recognizing occurrences of a given (closed) subterm in a term for Pattern :
+   [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed)
+   term [c] in a term [t] *)
+(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*)
+
+let subst_term_gen eq_fun c t = 
+  let rec substrec (k,c as kc) t =
+    match prefix_application eq_fun kc t with
+      | Some x -> x
+      | None ->
+    if eq_fun c t then mkRel k
+    else
+      map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t
+  in 
+  substrec (1,c) t
+
+(* Recognizing occurrences of a given (closed) subterm in a term :
+   [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed)
+   term [c1] in a term [t] *)
+(*i Meme remarque : a priori [c] n'est pas forcement clos i*)
+
+let replace_term_gen eq_fun c by_c in_t = 
+  let rec substrec (k,c as kc) t =
+    match my_prefix_application eq_fun kc by_c t with
+      | Some x -> x
+      | None ->
+    (if eq_fun c t then (lift k by_c) else
+      map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c))
+	substrec kc t)
+  in 
+  substrec (0,c) in_t
+
+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. *)
+
+let subst_term_occ_gen locs occ c t =
+  let maxocc = List.fold_right max locs 0 in
+  let pos = ref occ in
+  let check = ref true 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
+    else
+    if eq_constr c t then
+      let r = 
+	if except then 
+	  if List.mem (- !pos) locs then t else (mkRel k)
+	else 
+	  if List.mem !pos locs then (mkRel k) else t
+      in incr pos; r
+    else
+      map_constr_with_binders_left_to_right
+	(fun d (k,c) -> (k+1,lift 1 c))
+        substrec kc t
+  in
+  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
+  else 
+    let (nbocc,t') = subst_term_occ_gen locs 1 c t in
+    if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then
+      errorlabstrm "subst_term_occ" (str "Too few occurences");
+    t'
+
+let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
+  match bodyopt with
+    | None -> (id,None,subst_term_occ locs 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
+	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
+	  if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then
+	    errorlabstrm "subst_term_occ_decl" (str "Too few occurences");
+	  (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 vars_of_env env =
+  let s = 
+    Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s)
+      (named_context env) ~init:Idset.empty in
+  Sign.fold_rel_context
+    (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s)
+    (rel_context env) ~init:s
+
+let add_vname vars = function
+    Name id -> Idset.add id vars
+  | _ -> vars
+
+let id_of_global = Nametab.id_of_global
+
+let sort_hdchar = function
+  | Prop(_) -> "P"
+  | Type(_) -> "T"
+
+let hdchar env c = 
+  let rec hdrec k c =
+    match kind_of_term c with
+    | Prod (_,_,c)       -> hdrec (k+1) c
+    | Lambda (_,_,c)     -> hdrec (k+1) c
+    | LetIn (_,_,_,c)    -> hdrec (k+1) c
+    | Cast (c,_)         -> hdrec k c
+    | App (f,l)         -> hdrec k f
+    | Const kn       ->
+	let c = lowercase_first_char (id_of_label (label kn)) in
+	if c = "?" then "y" else c
+    | Ind ((kn,i) as x) ->
+	if i=0 then 
+	  lowercase_first_char (id_of_label (label kn))
+	else 
+	  lowercase_first_char (id_of_global (IndRef x))
+    | Construct ((sp,i) as x) ->
+	lowercase_first_char (id_of_global (ConstructRef x))
+    | Var id  -> lowercase_first_char id
+    | Sort s -> sort_hdchar s
+    | Rel n ->
+	(if n<=k then "p" (* the initial term is flexible product/function *)
+	 else
+	   try match Environ.lookup_rel (n-k) env with
+	     | (Name id,_,_)   -> lowercase_first_char id
+	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
+	   with Not_found -> "y")
+    | Fix ((_,i),(lna,_,_)) -> 
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | CoFix (i,(lna,_,_)) -> 
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | Meta _|Evar _|Case (_, _, _, _) -> "y"
+  in 
+  hdrec 0 c
+
+let id_of_name_using_hdchar env a = function
+  | Anonymous -> id_of_string (hdchar env a) 
+  | Name id   -> id
+
+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 prod_name   env (n,a,b) = mkProd (named_hd_type env a n, a, b)
+let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+
+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 name_assumption env (na,c,t) =
+  match c with
+    | None      -> (named_hd_type env t na, None, t)
+    | Some body -> (named_hd env body na, c, t)
+
+let name_context env hyps =
+  snd
+    (List.fold_left
+       (fun (env,hyps) d -> 
+	  let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
+       (env,[]) (List.rev hyps))
+
+let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b 
+let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
+
+let it_mkProd_or_LetIn_name env b hyps =
+  it_mkProd_or_LetIn b (name_context env hyps)
+let it_mkLambda_or_LetIn_name env b hyps =
+  it_mkLambda_or_LetIn b (name_context env hyps)
+
+(*************************)
+(*   Names environments  *)
+(*************************)
+type names_context = name list
+let add_name n nl = n::nl
+let lookup_name_of_rel p names =
+  try List.nth names (p-1)
+  with Invalid_argument _ | Failure _ -> raise Not_found
+let rec lookup_rel_of_name id names = 
+  let rec lookrec n = function
+    | Anonymous :: l  -> lookrec (n+1) l
+    | (Name id') :: l -> if id' = id then n else lookrec (n+1) l
+    | []            -> raise Not_found
+  in 
+  lookrec 1 names
+let empty_names_context = []
+
+let ids_of_rel_context sign =
+  Sign.fold_rel_context
+    (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
+    sign ~init:[]
+let ids_of_named_context sign =
+  Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
+
+let ids_of_context env = 
+  (ids_of_rel_context (rel_context env))
+  @ (ids_of_named_context (named_context env))
+
+let names_of_rel_context env =
+  List.map (fun (na,_,_) -> na) (rel_context env)
+
+(**** Globality of identifiers *)
+
+(* TODO temporary hack!!! *)
+let rec is_imported_modpath = function
+  | MPfile dp -> dp <> (Lib.library_dp ())
+(*  | MPdot (mp,_) -> is_imported_modpath mp *)
+  | _ -> false
+
+let is_imported_ref = function
+  | VarRef _ -> false
+  | ConstRef kn 
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) 
+(*  | ModTypeRef ln  *) -> 
+      let (mp,_,_) = repr_kn kn in is_imported_modpath mp
+(*  | ModRef mp ->
+      is_imported_modpath mp
+*)
+
+let is_global id =
+  try 
+    let ref = locate (make_short_qualid id) in
+    not (is_imported_ref ref)
+  with Not_found -> 
+    false
+
+let is_section_variable id =
+  try let _ = Sign.lookup_named id (Global.named_context()) in true
+  with Not_found -> false
+
+let next_global_ident_from allow_secvar id avoid = 
+  let rec next_rec id =
+    let id = next_ident_away_from id avoid in
+    if (allow_secvar && is_section_variable id) || not (is_global id) then
+      id
+    else  
+      next_rec (lift_ident id)
+  in 
+  next_rec id
+
+let next_global_ident_away allow_secvar id avoid =
+  let id  = next_ident_away id avoid in
+  if (allow_secvar && is_section_variable id) || not (is_global id) then
+    id
+  else  
+    next_global_ident_from allow_secvar (lift_ident id) avoid
+
+(* Nouvelle version de renommage des variables (DEC 98) *)
+(* This is the algorithm to display distinct bound variables 
+
+    - Règle 1 : un nom non anonyme, même non affiché, contribue à la liste
+      des noms à éviter 
+    - Règle 2 : c'est la dépendance qui décide si on affiche ou pas
+
+    Exemple : 
+    si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors
+    il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b)
+    mais f et f0 contribue à la liste des variables à éviter (en supposant 
+    que les noms f et f0 ne sont pas déjà pris)
+    Intérêt : noms homogènes dans un but avant et après Intro
+*)
+
+type used_idents = identifier list
+
+let occur_rel p env id = 
+  try lookup_name_of_rel p env = Name id
+  with Not_found -> false (* Unbound indice : may happen in debug *)
+
+let occur_id nenv id0 c =
+  let rec occur n c = match kind_of_term c with
+    | Var id when  id=id0 -> raise Occur
+    | Const kn when id_of_global (ConstRef kn) = id0 -> raise Occur
+    | Ind ind_sp
+	when id_of_global (IndRef ind_sp) = id0 ->
+        raise Occur
+    | Construct cstr_sp
+	when id_of_global (ConstructRef cstr_sp) = id0 ->
+        raise Occur
+    | Rel p when p>n & occur_rel (p-n) nenv id0 -> raise Occur
+    | _ -> iter_constr_with_binders succ occur n c
+  in 
+  try occur 1 c; false
+  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 =
+  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))
+    then next (lift_ident id)
+    else id
+  in 
+  match name with
+    | Name id   -> next id
+    | Anonymous -> 
+        (* Normally, an anonymous name is not dependent and will not be *)
+        (* taken into account by the function concrete_name; just in case *)
+        (* invent a valid name *)
+        id_of_string "H"
+
+(* 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                  *)
+
+let rec eta_reduce_head c =
+  match kind_of_term c with
+    | Lambda (_,c1,c') ->
+	(match kind_of_term (eta_reduce_head c') with
+           | App (f,cl) ->
+               let lastn = (Array.length cl) - 1 in 
+               if lastn < 1 then anomaly "application without arguments"
+               else
+                 (match kind_of_term cl.(lastn) with
+                    | Rel 1 ->
+			let c' =
+                          if lastn = 1 then f
+			  else mkApp (f, Array.sub cl 0 lastn)
+			in
+			if noccurn 1 c'
+                        then lift (-1) c'
+                        else c
+                    | _   -> c)
+           | _ -> c)
+    | _ -> c
+
+(* alpha-eta conversion : ignore print names and casts *)
+let eta_eq_constr =
+  let rec aux t1 t2 =
+    let t1 = eta_reduce_head (strip_head_cast t1)
+    and t2 = eta_reduce_head (strip_head_cast t2) in
+    t1=t2 or compare_constr aux t1 t2
+  in aux
+
+
+(* iterator on rel context *)
+let process_rel_context f env =
+  let sign = named_context env in
+  let rels = rel_context env in
+  let env0 = reset_with_named_context sign env in
+  Sign.fold_rel_context f rels ~init:env0
+
+let assums_of_rel_context sign =
+  Sign.fold_rel_context
+    (fun (na,c,t) l ->
+      match c with
+          Some _ -> l
+        | None -> (na, t)::l)
+    sign ~init:[]
+
+let lift_rel_context n sign =
+  let rec liftrec k = function
+    | (na,c,t)::sign ->
+	(na,option_app (liftn n k) c,type_app (liftn n k) t)
+	::(liftrec (k-1) sign)
+    | [] -> []
+  in
+  liftrec (rel_context_length sign) sign
+
+let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init
+
+let rec mem_named_context id = function
+  | (id',_,_) :: _ when id=id' -> true
+  | _ :: sign -> mem_named_context id sign
+  | [] -> false
+
+let make_all_name_different env =
+  let avoid = ref (ids_of_named_context (named_context env)) in
+  process_rel_context
+    (fun (na,c,t) newenv -> 
+       let id = next_name_away na !avoid in
+       avoid := id::!avoid;
+       push_rel (Name id,c,t) newenv)
+    env
+
+let global_vars env ids = Idset.elements (global_vars_set env ids)
+
+let global_vars_set_of_decl env = function
+  | (_,None,t) -> global_vars_set env t
+  | (_,Some c,t) ->
+      Idset.union (global_vars_set env t)
+        (global_vars_set env c)
+
+(* Remark: Anonymous var may be dependent in Evar's contexts *)
+let concrete_name is_goal_ccl 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 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
+  (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,t) -> mkCast (rename_bound_var env l c, t)
+  | x -> c
+
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
new file mode 100644
index 00000000..dd9742ea
--- /dev/null
+++ b/pretyping/termops.mli
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: termops.mli,v 1.21.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Term
+open Sign
+open Environ
+
+(* Universes *)
+(*val set_module : Names.dir_path -> unit*)
+val new_univ : unit -> Univ.universe
+val new_sort_in_family : sorts_family -> sorts
+
+(* iterators on terms *)
+val print_sort : sorts -> std_ppcmds
+val print_sort_family : sorts_family -> std_ppcmds
+val print_constr : constr -> std_ppcmds
+val prod_it : init:types -> (name * types) list -> types
+val lam_it : init:constr -> (name * types) list -> constr
+val rel_vect : int -> int -> constr array
+val rel_list : int -> int -> constr list
+val extended_rel_list : int -> rel_context -> constr list
+val extended_rel_vect : int -> rel_context -> constr array
+val push_rel_assum : name * types -> env -> env
+val push_rels_assum : (name * types) list -> env -> env
+val push_named_rec_types : name array * types array * 'a -> env -> env
+val lookup_rel_id : identifier -> rel_context -> int * types
+val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkProd_wo_LetIn : rel_declaration -> types -> types
+val it_mkProd_wo_LetIn : init:types -> rel_context -> types
+val it_mkProd_or_LetIn   : init:types -> rel_context -> types
+val it_mkLambda_or_LetIn : init:constr -> rel_context -> constr
+val it_named_context_quantifier :
+  (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
+val it_mkNamedProd_or_LetIn   : init:types -> named_context -> types
+val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
+
+(**********************************************************************)
+(* Generic iterators on constr                                        *)
+
+val map_constr_with_named_binders :
+  (name -> 'a -> 'a) ->
+  ('a -> constr -> constr) -> 'a -> constr -> constr
+val map_constr_with_binders_left_to_right :
+  (rel_declaration -> 'a -> 'a) -> 
+  ('a -> constr -> constr) ->
+    'a -> constr -> constr
+val map_constr_with_full_binders :
+  (rel_declaration -> 'a -> 'a) ->
+  ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
+   subterms of [c] starting from [acc] and proceeding from left to
+   right according to the usual representation of the constructions as
+   [fold_constr] but it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive *)
+
+val fold_constr_with_binders :
+  ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
+
+val iter_constr_with_full_binders :
+  (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> 
+    constr -> unit
+
+(**********************************************************************)
+
+val strip_head_cast : constr -> constr
+
+(* occur checks *)
+exception Occur
+val occur_meta : types -> bool
+val occur_existential : types -> bool
+val occur_const : constant -> types -> bool
+val occur_evar : existential_key -> types -> bool
+val occur_in_global : env -> identifier -> constr -> unit
+val occur_var : env -> identifier -> types -> bool
+val occur_var_in_decl :
+  env ->
+  identifier -> 'a * types option * types -> bool
+val occur_term : constr -> constr -> bool
+val free_rels : constr -> Intset.t
+
+(* Substitution of metavariables *)
+type metamap = (metavariable * constr) list 
+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
+   reduction of let *)
+val dependent : constr -> constr -> bool
+val subst_term_gen :
+  (constr -> constr -> bool) -> constr -> constr -> constr
+val replace_term_gen :
+  (constr -> constr -> bool) ->
+    constr -> constr -> constr -> constr
+val subst_term : constr -> constr -> constr
+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
+val subst_term_occ_decl :
+  int list -> constr -> named_declaration -> named_declaration
+
+(* Alternative term equalities *)
+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 prod_name : env -> name * types * types -> constr
+val lambda_name : env -> name * types * constr -> constr
+val prod_create : env -> types * types -> constr
+val lambda_create : env -> types * constr -> constr
+val name_assumption : env -> rel_declaration -> rel_declaration
+val name_context : env -> rel_context -> rel_context
+
+val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types
+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
+
+(* name contexts *)
+type names_context = name list
+val add_name : name -> names_context -> names_context
+val lookup_name_of_rel : int -> names_context -> name
+val lookup_rel_of_name : identifier -> names_context -> int
+val empty_names_context : names_context
+val ids_of_rel_context : rel_context -> identifier list
+val ids_of_named_context : named_context -> identifier list
+val ids_of_context : env -> identifier list
+val names_of_rel_context : env -> names_context
+
+(* Set of local names *)
+val vars_of_env: env -> Idset.t
+val add_vname : Idset.t -> name -> Idset.t
+
+(* sets of free identifiers *)
+type used_idents = identifier list
+val occur_rel : int -> name list -> identifier -> bool
+val occur_id : name list -> identifier -> constr -> bool
+
+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
+val concrete_name :
+  bool -> identifier list -> name list -> name -> constr -> 
+    name * identifier list
+val concrete_let_name :
+  bool -> 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 fold_named_context_both_sides :
+  ('a -> named_declaration -> named_declaration list -> 'a) ->
+    named_context -> init:'a -> 'a
+val mem_named_context : identifier -> named_context -> bool
+val make_all_name_different : env -> env
+
+val global_vars : env -> constr -> identifier list
+val global_vars_set_of_decl : env -> named_declaration -> Idset.t
+
+(* Test if an identifier is the basename of a global reference *)
+val is_section_variable : identifier -> bool
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
new file mode 100644
index 00000000..a84cd612
--- /dev/null
+++ b/pretyping/typing.ml
@@ -0,0 +1,174 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* $Id: typing.ml,v 1.32.6.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Environ
+open Reductionops
+open Type_errors
+open Pretype_errors
+open Inductive
+open Typeops
+
+let vect_lift = Array.mapi lift
+let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
+
+type 'a mach_flags = {
+  fix : bool;
+  nocheck : bool }
+
+(* The typing machine without information, without universes but with
+   existential variables. *)
+
+let assumption_of_judgment env sigma j =
+  assumption_of_judgment env (j_nf_evar sigma j)
+
+let type_judgment env sigma j =
+  type_judgment env (j_nf_evar sigma j)
+
+
+let rec execute mf env sigma cstr =
+  match kind_of_term cstr with
+    | Meta n ->
+	error "execute: found a non-instanciated goal"
+
+    | Evar ev ->
+	let ty = Instantiate.existential_type sigma ev in
+	let jty = execute mf env sigma ty in
+	let jty = assumption_of_judgment env sigma jty in
+	{ uj_val = cstr; uj_type = jty }
+	
+    | Rel n -> 
+	judge_of_relative env n
+
+    | Var id -> 
+        judge_of_variable env id
+	  
+    | Const c ->
+        make_judge cstr (constant_type env c)
+	  
+    | Ind ind ->
+	make_judge cstr (type_of_inductive env ind)
+	  
+    | Construct cstruct -> 
+	make_judge cstr (type_of_constructor env cstruct)
+	  
+    | Case (ci,p,c,lf) ->
+        let cj = execute mf env sigma c in
+        let pj = execute mf env sigma p in
+        let lfj = execute_array mf env sigma lf in
+        let (j,_) = judge_of_case env ci pj cj lfj in
+        j
+  
+    | Fix ((vn,i as vni),recdef) ->
+        if (not mf.fix) && array_exists (fun n -> n < 0) vn then
+          error "General Fixpoints not allowed";
+        let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+	let fix = (vni,recdef') in
+        check_fix env fix;
+	make_judge (mkFix fix) tys.(i)
+	  
+    | CoFix (i,recdef) ->
+        let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+        let cofix = (i,recdef') in
+        check_cofix env cofix;
+	make_judge (mkCoFix cofix) tys.(i)
+	  
+    | Sort (Prop c) -> 
+	judge_of_prop_contents c
+
+    | Sort (Type u) ->
+	judge_of_type u
+	  
+    | App (f,args) ->
+	let j = execute mf env sigma f in
+        let jl = execute_array mf env sigma args in
+	let (j,_) = judge_of_apply env j jl in
+	j
+	    
+    | Lambda (name,c1,c2) -> 
+        let j = execute mf env sigma c1 in
+	let var = type_judgment env sigma j in
+	let env1 = push_rel (name,None,var.utj_val) env in
+        let j' = execute mf env1 sigma c2 in 
+        judge_of_abstraction env1 name var j'
+	  
+    | Prod (name,c1,c2) ->
+        let j = execute mf env sigma c1 in
+        let varj = type_judgment env sigma j in
+	let env1 = push_rel (name,None,varj.utj_val) env in
+        let j' = execute mf env1 sigma c2 in
+        let varj' = type_judgment env1 sigma j' in
+	judge_of_product env name varj varj'
+
+     | LetIn (name,c1,c2,c3) ->
+        let j1 = execute mf env sigma c1 in
+        let j2 = execute mf env sigma c2 in
+        let j2 = type_judgment env sigma j2 in
+        let _ =  judge_of_cast env j1 j2 in
+        let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+        let j3 = execute mf env1 sigma c3 in
+        judge_of_letin env name j1 j2 j3
+  
+    | Cast (c,t) ->
+        let cj = execute mf env sigma c in
+        let tj = execute mf env sigma t in
+	let tj = type_judgment env sigma tj in
+        let j, _ = judge_of_cast env cj tj in
+	j
+
+and execute_recdef mf env sigma (names,lar,vdef) =
+  let larj = execute_array mf env sigma lar in
+  let lara = Array.map (assumption_of_judgment env sigma) larj in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let vdefj = execute_array mf env1 sigma vdef in
+  let vdefv = Array.map j_val vdefj in
+  let _ = type_fixpoint env1 names lara vdefj in
+  (names,lara,vdefv)
+
+and execute_array mf env sigma v =
+  let jl = execute_list mf env sigma (Array.to_list v) in
+  Array.of_list jl
+
+and execute_list mf env sigma = function
+  | [] -> 
+      []
+  | c::r -> 
+      let j = execute mf env sigma c in 
+      let jr = execute_list mf env sigma r in
+      j::jr
+
+
+let safe_machine env sigma constr = 
+  let mf = { fix = false; nocheck = false } in
+  execute mf env sigma constr
+
+let unsafe_machine env sigma constr =
+  let mf = { fix = false; nocheck = true } in
+  execute mf env sigma constr
+
+(* Type of a constr *)
+
+let type_of env sigma c = 
+  let j = safe_machine env sigma c in 
+  (* No normalization: it breaks Pattern! *)
+  (*nf_betaiota*) (body_of_type j.uj_type)
+
+(* The typed type of a judgment. *)
+
+let execute_type env sigma constr = 
+  let j = execute { fix=false; nocheck=true } env sigma constr in
+  assumption_of_judgment env sigma j
+
+let execute_rec_type env sigma constr = 
+  let j = execute { fix=false; nocheck=false } env sigma constr in
+  assumption_of_judgment env sigma j
+
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
new file mode 100644
index 00000000..4ea74dcd
--- /dev/null
+++ b/pretyping/typing.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  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: typing.mli,v 1.7.14.1 2004/07/16 19:30:47 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Environ
+open Evd
+(*i*)
+
+(* This module provides the typing machine with existential variables
+   (but without universes). *)
+
+val unsafe_machine : env -> evar_map -> constr -> unsafe_judgment
+
+val type_of : env -> evar_map -> constr -> constr
+
+val execute_type : env -> evar_map -> constr -> types
+
+val execute_rec_type : env -> evar_map -> constr -> types
+