Imported Upstream version 8.0pl1upstream/8.0pl1

43 files changed, 10445 insertions, 0 deletions

diff --git a/kernel/closure.ml b/kernel/closure.ml
new file mode 100644
index 00000000..1a635ccf
--- /dev/null
+++ b/kernel/closure.ml
@@ -0,0 +1,1140 @@
+(************************************************************************)
+(*  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: closure.ml,v 1.54.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+open Util
+open Pp
+open Term
+open Names
+open Declarations
+open Environ
+open Esubst
+
+
+let stats = ref false
+let share = ref true
+
+(* Profiling *)
+let beta = ref 0
+let delta = ref 0
+let zeta = ref 0
+let evar = ref 0
+let iota = ref 0
+let prune = ref 0
+
+let reset () =
+  beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0
+
+let stop() =
+  msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+	 str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++
+         str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]")
+
+let incr_cnt red cnt =
+  if red then begin
+    if !stats then incr cnt;
+    true
+  end else 
+    false
+
+let with_stats c =
+  if !stats then begin
+    reset();
+    let r = Lazy.force c in
+    stop();
+    r
+  end else
+    Lazy.force c
+
+type transparent_state = Idpred.t * KNpred.t
+
+let all_opaque = (Idpred.empty, KNpred.empty)
+let all_transparent = (Idpred.full, KNpred.full)
+
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+  val no_red : reds
+  val red_add : reds -> red_kind -> reds
+  val red_sub : reds -> red_kind -> reds
+  val red_add_transparent : reds -> transparent_state -> reds
+  val mkflags : red_kind list -> reds
+  val red_set : reds -> red_kind -> bool
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags = (struct
+
+  (* [r_const=(true,cl)] means all constants but those in [cl] *)
+  (* [r_const=(false,cl)] means only those in [cl] *)
+  (* [r_delta=true] just mean [r_const=(true,[])] *)
+
+  type reds = {
+    r_beta : bool;
+    r_delta : bool;
+    r_const : transparent_state;
+    r_zeta : bool;
+    r_evar : bool;
+    r_iota : bool }
+
+  type red_kind = BETA | DELTA | IOTA | ZETA
+	      | CONST of constant | VAR of identifier
+  let fBETA = BETA
+  let fDELTA = DELTA
+  let fIOTA = IOTA
+  let fZETA = ZETA
+  let fCONST kn  = CONST kn
+  let fVAR id  = VAR id
+  let no_red = {
+    r_beta = false;
+    r_delta = false;
+    r_const = all_opaque;
+    r_zeta = false;
+    r_evar = false;
+    r_iota = false }
+
+  let red_add red = function
+    | BETA -> { red with r_beta = true }
+    | DELTA -> { red with r_delta = true; r_const = all_transparent }
+    | CONST kn ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = l1, KNpred.add kn l2 }
+    | IOTA -> { red with r_iota = true }
+    | ZETA -> { red with r_zeta = true }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.add id l1, l2 }
+
+  let red_sub red = function
+    | BETA -> { red with r_beta = false }
+    | DELTA -> { red with r_delta = false }
+    | CONST kn ->
+ 	let (l1,l2) = red.r_const in
+	{ red with r_const = l1, KNpred.remove kn l2 }
+    | IOTA -> { red with r_iota = false }
+    | ZETA -> { red with r_zeta = false }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.remove id l1, l2 }
+
+  let red_add_transparent red tr =
+    { red with r_const = tr } 
+
+  let mkflags = List.fold_left red_add no_red
+
+  let red_set red = function
+    | BETA -> incr_cnt red.r_beta beta
+    | CONST kn -> 
+	let (_,l) = red.r_const in
+	let c = KNpred.mem kn l in
+	incr_cnt c delta
+    | VAR id -> (* En attendant d'avoir des kn pour les Var *)
+	let (l,_) = red.r_const in
+	let c = Idpred.mem id l in
+	incr_cnt c delta
+    | ZETA -> incr_cnt red.r_zeta zeta
+    | IOTA -> incr_cnt red.r_iota iota
+    | DELTA -> (* Used for Rel/Var defined in context *)
+	incr_cnt red.r_delta delta
+
+  let red_get_const red =
+    let p1,p2 = red.r_const in
+    let (b1,l1) = Idpred.elements p1 in
+    let (b2,l2) = KNpred.elements p2 in
+    if b1=b2 then
+      let l1' = List.map (fun x -> EvalVarRef x) l1 in
+      let l2' = List.map (fun x -> EvalConstRef x) l2 in
+      (b1, l1' @ l2')
+    else error "unrepresentable pair of predicate"
+
+end : RedFlagsSig)
+
+open RedFlags
+
+let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA]
+let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
+let betaiota = mkflags [fBETA;fIOTA]
+let beta = mkflags [fBETA]
+let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
+let unfold_red kn = 
+  let flag = match kn with
+    | EvalVarRef id -> fVAR id
+    | EvalConstRef kn -> fCONST kn
+  in (* Remove fZETA for finer behaviour ? *)
+  mkflags [fBETA;flag;fIOTA;fZETA]
+
+(************************* Obsolète
+(* [r_const=(true,cl)] means all constants but those in [cl] *)
+(* [r_const=(false,cl)] means only those in [cl] *)
+type reds = {
+  r_beta : bool;
+  r_const : bool * constant_path list * identifier list;
+  r_zeta : bool;
+  r_evar : bool;
+  r_iota : bool }
+
+let betadeltaiota_red = {
+  r_beta = true;
+  r_const = true,[],[];
+  r_zeta = true;
+  r_evar = true;
+  r_iota = true } 
+
+let betaiota_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = true }
+		     
+let beta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let no_red = {
+  r_beta = false;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let betaiotazeta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = true;
+  r_evar = false;
+  r_iota = true }
+
+let unfold_red kn =
+  let c = match kn with
+    | EvalVarRef id -> false,[],[id]
+    | EvalConstRef kn -> false,[kn],[]
+  in {
+  r_beta = true;
+  r_const = c;
+  r_zeta = true;   (* false for finer behaviour ? *)
+  r_evar = false;
+  r_iota = true }
+
+(* Sets of reduction kinds.
+   Main rule: delta implies all consts (both global (= by
+   kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
+   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+   a LetIn expression is Letin reduction *)
+
+type red_kind =
+    BETA | DELTA | ZETA | IOTA
+  | CONST of constant_path list | CONSTBUT of constant_path list
+  | VAR of identifier | VARBUT of identifier
+
+let rec red_add red = function
+  | BETA -> { red with r_beta = true }
+  | DELTA ->
+      (match red.r_const with
+	| _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags"
+	| _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true })
+  | CONST cl ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 })
+  | CONSTBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, list_union cl l1, l2;
+		r_zeta = true; r_evar = true })
+  | IOTA -> { red with r_iota = true }
+  | ZETA -> { red with r_zeta = true }
+  | VAR id ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 })
+  | VARBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, l1, list_union [cl] l2;
+		r_zeta = true; r_evar = true })
+
+let red_delta_set red =
+  let b,_,_ = red.r_const in b
+
+let red_local_const = red_delta_set
+
+(* to know if a redex is allowed, only a subset of red_kind is used ... *)
+let red_set red = function
+  | BETA -> incr_cnt red.r_beta beta
+  | CONST [kn] -> 
+      let (b,l,_) = red.r_const in
+      let c = List.mem kn l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | VAR id -> (* En attendant d'avoir des kn pour les Var *)
+     let (b,_,l) = red.r_const in
+      let c = List.mem id l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | ZETA -> incr_cnt red.r_zeta zeta
+  | EVAR -> incr_cnt red.r_zeta evar
+  | IOTA -> incr_cnt red.r_iota iota
+  | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*)
+  (* Not for internal use *)
+  | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented"
+
+(* Gives the constant list *)
+let red_get_const red =
+  let b,l1,l2 = red.r_const in
+  let l1' = List.map (fun x -> EvalConstRef x) l1 in
+  let l2' = List.map (fun x -> EvalVarRef x) l2 in
+  b, l1' @ l2'
+fin obsolète **************)
+(* specification of the reduction function *)
+
+
+(* Flags of reduction and cache of constants: 'a is a type that may be
+ * mapped to constr. 'a infos implements a cache for constants and
+ * abstractions, storing a representation (of type 'a) of the body of
+ * this constant or abstraction.
+ *  * i_tab is the cache table of the results
+ *  * i_repr is the function to get the representation from the current
+ *         state of the cache and the body of the constant. The result
+ *         is stored in the table.
+ *  * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables
+ *    and only those with index 1 and 3 have bodies which are c and d resp.
+ *  * i_vars is the list of _defined_ named variables.
+ *
+ * ref_value_cache searchs in the tab, otherwise uses i_repr to
+ * compute the result and store it in the table. If the constant can't
+ * be unfolded, returns None, but does not store this failure.  * This
+ * doesn't take the RESET into account. You mustn't keep such a table
+ * after a Reset.  * This type is not exported. Only its two
+ * instantiations (cbv or lazy) are.
+ *)
+
+type table_key =
+  | ConstKey of constant
+  | VarKey of identifier
+  | FarRelKey of int
+   (* FarRel: index in the rel_context part of _initial_ environment *)
+
+type 'a infos = {
+  i_flags : reds;
+  i_repr : 'a infos -> constr -> 'a;
+  i_env : env;
+  i_rels : int * (int * constr) list;
+  i_vars : (identifier * constr) list;
+  i_tab : (table_key, 'a) Hashtbl.t }
+
+let info_flags info = info.i_flags
+
+let ref_value_cache info ref =
+  try  
+    Some (Hashtbl.find info.i_tab ref)
+  with Not_found ->
+  try
+    let body =
+      match ref with
+	| FarRelKey n ->
+	    let (s,l) = info.i_rels in lift n (List.assoc (s-n) l)
+	| VarKey id -> List.assoc id info.i_vars
+	| ConstKey cst -> constant_value info.i_env cst
+    in
+    let v = info.i_repr info body in
+    Hashtbl.add info.i_tab ref v;
+    Some v
+  with
+    | Not_found (* List.assoc *)
+    | NotEvaluableConst _ (* Const *)
+      -> None
+
+let defined_vars flags env =
+(*  if red_local_const (snd flags) then*)
+    fold_named_context 
+      (fun env (id,b,t) e ->
+	 match b with
+	   | None -> e
+	   | Some body -> (id, body)::e)
+      env ~init:[]
+(*  else []*)
+
+let defined_rels flags env =
+(*  if red_local_const (snd flags) then*)
+  fold_rel_context 
+      (fun env (id,b,t) (i,subs) ->
+	 match b with
+	   | None -> (i+1, subs)
+	   | Some body -> (i+1, (i,body) :: subs))
+      env ~init:(0,[])
+(*  else (0,[])*)
+
+
+let rec mind_equiv info kn1 kn2 = 
+  kn1 = kn2 ||
+	match (lookup_mind kn1 info.i_env).mind_equiv with
+	    Some kn1' -> mind_equiv info kn2 kn1'
+	  | None -> match (lookup_mind kn2 info.i_env).mind_equiv with
+		Some kn2' -> mind_equiv info kn2' kn1
+	      | None -> false
+
+let create mk_cl flgs env =
+  { i_flags = flgs;
+    i_repr = mk_cl;
+    i_env = env;
+    i_rels = defined_rels flgs env;
+    i_vars = defined_vars flgs env;
+    i_tab = Hashtbl.create 17 }
+
+
+(**********************************************************************)
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+
+type 'a stack_member =
+  | Zapp of 'a list
+  | Zcase of case_info * 'a * 'a array
+  | Zfix of 'a * 'a stack
+  | Zshift of int
+  | Zupdate of 'a
+
+and 'a stack = 'a stack_member list
+
+let empty_stack = []
+let append_stack_list = function
+  | ([],s) -> s
+  | (l1, Zapp l :: s) -> Zapp (l1@l) :: s
+  | (l1, s) -> Zapp l1 :: s
+let append_stack v s = append_stack_list (Array.to_list v, s)
+
+(* Collapse the shifts in the stack *)
+let zshift n s =
+  match (n,s) with
+      (0,_) -> s
+    | (_,Zshift(k)::s) -> Zshift(n+k)::s
+    | _ -> Zshift(n)::s
+
+let rec stack_args_size = function
+  | Zapp l::s -> List.length l + stack_args_size s
+  | Zshift(_)::s -> stack_args_size s
+  | Zupdate(_)::s -> stack_args_size s
+  | _ -> 0
+
+(* When used as an argument stack (only Zapp can appear) *)
+let rec decomp_stack = function
+  | Zapp[v]::s -> Some (v, s)
+  | Zapp(v::l)::s -> Some (v, (Zapp l :: s))
+  | Zapp [] :: s -> decomp_stack s
+  | _ -> None
+let rec decomp_stackn = function
+  | Zapp [] :: s -> decomp_stackn s
+  | Zapp l :: s -> (Array.of_list l, s)
+  | _ -> assert false
+let array_of_stack s =
+  let rec stackrec = function
+  | [] -> []
+  | Zapp args :: s -> args :: (stackrec s)
+  | _ -> assert false
+  in Array.of_list (List.concat (stackrec s))
+let rec list_of_stack = function
+  | [] -> []
+  | Zapp args :: s -> args @ (list_of_stack s)
+  | _ -> assert false
+let rec app_stack = function
+  | f, [] -> f
+  | f, (Zapp [] :: s) -> app_stack (f, s)
+  | f, (Zapp args :: s) -> 
+      app_stack (applist (f, args), s)
+  | _ -> assert false
+let rec stack_assign s p c = match s with
+  | Zapp args :: s ->
+      let q = List.length args in 
+      if p >= q then
+	Zapp args :: stack_assign s (p-q) c
+      else
+        (match list_chop p args with
+            (bef, _::aft) -> Zapp (bef@c::aft) :: s
+          | _ -> assert false)
+  | _ -> s
+let rec stack_tail p s =
+  if p = 0 then s else
+    match s with
+      | Zapp args :: s ->
+	  let q = List.length args in
+	  if p >= q then stack_tail (p-q) s
+	  else Zapp (list_skipn p args) :: s
+      | _ -> failwith "stack_tail"
+let rec stack_nth s p = match s with
+  | Zapp args :: s ->
+      let q = List.length args in
+      if p >= q then stack_nth s (p-q)
+      else List.nth args p
+  | _ -> raise Not_found
+
+
+(**********************************************************************)
+(* Lazy reduction: the one used in kernel operations                  *)
+
+(* type of shared terms. fconstr and frterm are mutually recursive.
+ * Clone of the constr structure, but completely mutable, and
+ * annotated with reduction state (reducible or not).
+ *  - FLIFT is a delayed shift; allows sharing between 2 lifted copies
+ *    of a given term.
+ *  - FCLOS is a delayed substitution applied to a constr
+ *  - FLOCKED is used to erase the content of a reference that must
+ *    be updated. This is to allow the garbage collector to work
+ *    before the term is computed.
+ *)
+
+(* Norm means the term is fully normalized and cannot create a redex
+     when substituted
+   Cstr means the term is in head normal form and that it can
+     create a redex when substituted (i.e. constructor, fix, lambda)
+   Whnf means we reached the head normal form and that it cannot
+     create a redex when substituted
+   Red is used for terms that might be reduced
+*)
+type red_state = Norm | Cstr | Whnf | Red
+
+let neutr = function
+  | (Whnf|Norm) -> Whnf
+  | (Red|Cstr) -> Red
+
+type fconstr = { 
+  mutable norm: red_state; 
+  mutable term: fterm }
+
+and fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * fconstr
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+let fterm_of v = v.term
+let set_norm v = v.norm <- Norm
+let is_val v = v.norm = Norm
+
+(* Could issue a warning if no is still Red, pointing out that we loose
+   sharing. *)
+let update v1 (no,t) =
+  if !share then
+    (v1.norm <- no;
+     v1.term <- t;
+     v1)
+  else {norm=no;term=t}
+
+(* Lifting. Preserves sharing (useful only for cell with norm=Red).
+   lft_fconstr always create a new cell, while lift_fconstr avoids it
+   when the lift is 0. *)
+let rec lft_fconstr n ft =
+  match ft.term with
+    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FAtom _) -> ft
+    | FRel i -> {norm=Norm;term=FRel(i+n)}
+    | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))}
+    | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))}
+    | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))}
+    | FLIFT(k,m) -> lft_fconstr (n+k) m
+    | FLOCKED -> anomaly "lft_constr found locked term"
+    | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
+let lift_fconstr k f =
+  if k=0 then f else lft_fconstr k f
+let lift_fconstr_vect k v =
+  if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
+let lift_fconstr_list k l =
+  if k=0 then l else List.map (fun f -> lft_fconstr k f) l
+
+let clos_rel e i =
+  match expand_rel i e with
+    | Inl(n,mt) -> lift_fconstr n mt
+    | Inr(k,None) -> {norm=Norm; term= FRel k}
+    | Inr(k,Some p) ->
+        lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)}
+
+(* since the head may be reducible, we might introduce lifts of 0 *)
+let compact_stack head stk =
+  let rec strip_rec depth = function
+    | Zshift(k)::s -> strip_rec (depth+k) s
+    | Zupdate(m)::s ->
+        (* Be sure to create a new cell otherwise sharing would be
+           lost by the update operation *)
+        let h' = lft_fconstr depth head in
+        let _ = update m (h'.norm,h'.term) in
+        strip_rec depth s
+    | stk -> zshift depth stk in
+  strip_rec 0 stk
+
+(* Put an update mark in the stack, only if needed *)
+let zupdate m s =
+  if !share & m.norm = Red
+  then
+    let s' = compact_stack m s in
+    let _ = m.term <- FLOCKED in
+    Zupdate(m)::s'
+  else s
+
+(* Closure optimization: *)
+let rec compact_constr (lg, subs as s) c k =
+  match kind_of_term c with
+      Rel i ->
+        if i < k then c,s else
+          (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs)
+          with Not_found -> mkRel (k+lg), (lg+1, (i-k+1)::subs))
+    | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s
+    | Evar(ev,v) ->
+        let (v',s) = compact_vect s v k in
+        if v==v' then c,s else mkEvar(ev,v'),s
+    | Cast(a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b k in
+        if a==a' && b==b' then c,s else mkCast(a',b'), s
+    | App(f,v) ->
+        let (f',s) = compact_constr s f k in
+        let (v',s) = compact_vect s v k in
+        if f==f' && v==v' then c,s else mkApp(f',v'), s
+    | Lambda(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else mkLambda(n,a',b'), s
+    | Prod(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else mkProd(n,a',b'), s
+    | LetIn(n,a,ty,b) ->
+        let (a',s) = compact_constr s a k in
+        let (ty',s) = compact_constr s ty k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && ty==ty' && b==b' then c,s else mkLetIn(n,a',ty',b'), s
+    | Fix(fi,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else mkFix(fi,(na,ty',bd')), s
+    | CoFix(i,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else mkCoFix(i,(na,ty',bd')), s
+    | Case(ci,p,a,br) ->
+        let (p',s) = compact_constr s p k in
+        let (a',s) = compact_constr s a k in
+        let (br',s) = compact_vect s br k in
+        if p==p' && a==a' && br==br' then c,s else mkCase(ci,p',a',br'),s
+and compact_vect s v k = compact_v [] s v k (Array.length v - 1)
+and compact_v acc s v k i =
+  if i < 0 then
+    let v' = Array.of_list acc in
+    if array_for_all2 (==) v v' then v,s else v',s
+  else
+    let (a',s') = compact_constr s v.(i) k in
+    compact_v (a'::acc) s' v k (i-1)
+
+(* Computes the minimal environment of a closure.
+   Idea: if the subs is not identity, the term will have to be
+   reallocated entirely (to propagate the substitution). So,
+   computing the set of free variables does not change the
+   complexity. *)
+let optimise_closure env c =
+  if is_subs_id env then (env,c) else
+    let (c',(_,s)) = compact_constr (0,[]) c 1 in
+    let env' = List.fold_left
+      (fun subs i -> subs_cons (clos_rel env i, subs)) (ESID 0) s in
+    (env',c')
+
+let mk_lambda env t =
+(*  let (env,t) = optimise_closure env t in*)
+  let (rvars,t') = decompose_lam t in
+  FLambda(List.length rvars, List.rev rvars, t', env)
+
+let destFLambda clos_fun t =
+  match t.term with
+      FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b)
+    | FLambda(n,(na,ty)::tys,b,e) ->
+        (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)})
+    | _ -> assert false
+
+(* Optimization: do not enclose variables in a closure.
+   Makes variable access much faster *)
+let mk_clos e t =
+  match kind_of_term t with
+    | Rel i -> clos_rel e i
+    | Var x -> { norm = Red; term = FFlex (VarKey x) }
+    | Const c -> { norm = Red; term = FFlex (ConstKey c) }
+    | Meta _ | Sort _ ->  { norm = Norm; term = FAtom t }
+    | Ind kn -> { norm = Norm; term = FInd kn }
+    | Construct kn -> { norm = Cstr; term = FConstruct kn }
+    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) ->
+        {norm = Red; term = FCLOS(t,e)}
+
+let mk_clos_vect env v = Array.map (mk_clos env) v
+
+(* Translate the head constructor of t from constr to fconstr. This
+   function is parameterized by the function to apply on the direct
+   subterms.
+   Could be used insted of mk_clos. *)
+let mk_clos_deep clos_fun env t =
+  match kind_of_term t with
+    | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) ->
+        mk_clos env t
+    | Cast (a,b) ->
+        { norm = Red;
+          term = FCast (clos_fun env a, clos_fun env b)}
+    | App (f,v) ->
+        { norm = Red;
+	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
+    | Case (ci,p,c,v) ->
+        { norm = Red;
+	  term = FCases (ci, clos_fun env p, clos_fun env c,
+			 Array.map (clos_fun env) v) }
+    | Fix fx ->
+        { norm = Cstr; term = FFix (fx, env) }
+    | CoFix cfx ->
+        { norm = Cstr; term = FCoFix(cfx,env) }
+    | Lambda _ ->
+        { norm = Cstr; term = mk_lambda env t }
+    | Prod (n,t,c)   ->
+        { norm = Whnf;
+	  term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) }
+    | LetIn (n,b,t,c) ->
+        { norm = Red;
+	  term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) }
+    | Evar(ev,args) ->
+	{ norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) }
+
+(* A better mk_clos? *)
+let mk_clos2 = mk_clos_deep mk_clos
+
+(* The inverse of mk_clos_deep: move back to constr *)
+let rec to_constr constr_fun lfts v =
+  match v.term with
+    | FRel i -> mkRel (reloc_rel i lfts)
+    | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts)
+    | FFlex (VarKey x) -> mkVar x
+    | FAtom c ->
+        (match kind_of_term c with
+          | Sort s -> mkSort s
+          | Meta m -> mkMeta m
+          | _ -> assert false)
+    | FCast (a,b) ->
+        mkCast (constr_fun lfts a, constr_fun lfts b)
+    | FFlex (ConstKey op) -> mkConst op
+    | FInd op -> mkInd op
+    | FConstruct op -> mkConstruct op
+    | FCases (ci,p,c,ve) ->
+	mkCase (ci, constr_fun lfts p,
+                constr_fun lfts c,
+		Array.map (constr_fun lfts) ve)
+    | FFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn n lfts in
+	mkFix (op, (lna, Array.map (constr_fun lfts) ftys,
+		         Array.map (constr_fun lfts') fbds))
+    | FCoFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn (Array.length bds) lfts in
+	mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys,
+		           Array.map (constr_fun lfts') fbds))
+    | FApp (f,ve) ->
+	mkApp (constr_fun lfts f,
+	       Array.map (constr_fun lfts) ve)
+    | FLambda _ ->
+        let (na,ty,bd) = destFLambda mk_clos2 v in
+	mkLambda (na, constr_fun lfts ty,
+	              constr_fun (el_lift lfts) bd)
+    | FProd (n,t,c)   ->
+	mkProd (n, constr_fun lfts t,
+	           constr_fun (el_lift lfts) c)
+    | FLetIn (n,b,t,f,e) ->
+        let fc = mk_clos2 (subs_lift e) f in
+	mkLetIn (n, constr_fun lfts b,
+	            constr_fun lfts t,
+	            constr_fun (el_lift lfts) fc)
+    | FEvar (ev,args) -> mkEvar(ev,Array.map (constr_fun lfts) args)
+    | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
+    | FCLOS (t,env) ->
+        let fr = mk_clos2 env t in
+        let unfv = update v (fr.norm,fr.term) in
+        to_constr constr_fun lfts unfv
+    | FLOCKED -> (*anomaly "Closure.to_constr: found locked term"*)
+mkVar(id_of_string"_LOCK_")
+
+(* This function defines the correspondance between constr and
+   fconstr. When we find a closure whose substitution is the identity,
+   then we directly return the constr to avoid possibly huge
+   reallocation. *)
+let term_of_fconstr =
+  let rec term_of_fconstr_lift lfts v =
+    match v.term with
+      | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t
+      | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts ->
+          compose_lam (List.rev tys) f
+      | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx
+      | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
+      | _ -> to_constr term_of_fconstr_lift lfts v in
+  term_of_fconstr_lift ELID
+
+
+
+(* fstrong applies unfreeze_fun recursively on the (freeze) term and
+ * yields a term.  Assumes that the unfreeze_fun never returns a
+ * FCLOS term. 
+let rec fstrong unfreeze_fun lfts v =
+  to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
+*)
+
+let rec zip zfun m stk =
+  match stk with
+    | [] -> m
+    | Zapp args :: s ->
+        let args = Array.of_list args in
+        zip zfun {norm=neutr m.norm; term=FApp(m, Array.map zfun args)} s
+    | Zcase(ci,p,br)::s ->
+        let t = FCases(ci, zfun p, m, Array.map zfun br) in
+        zip zfun {norm=neutr m.norm; term=t} s
+    | Zfix(fx,par)::s ->
+        zip zfun fx (par @ append_stack_list ([m], s))
+    | Zshift(n)::s ->
+        zip zfun (lift_fconstr n m) s
+    | Zupdate(rf)::s ->
+        zip zfun (update rf (m.norm,m.term)) s
+
+let fapp_stack (m,stk) = zip (fun x -> x) m stk
+
+(*********************************************************************)
+
+(* The assertions in the functions below are granted because they are
+   called only when m is a constructor, a cofix
+   (strip_update_shift_app), a fix (get_nth_arg) or an abstraction
+   (strip_update_shift, through get_arg). *)
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift head stk =
+  assert (head.norm <> Red);
+  let rec strip_rec h depth = function
+    | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
+    | Zupdate(m)::s ->
+        strip_rec (update m (h.norm,h.term)) depth s
+    | stk -> (depth,stk) in
+  strip_rec head 0 stk
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift_app head stk =
+  assert (head.norm <> Red);
+  let rec strip_rec rstk h depth = function
+    | Zshift(k) as e :: s ->
+        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
+    | (Zapp args :: s) as stk ->
+        strip_rec (Zapp args :: rstk)
+          {norm=h.norm;term=FApp(h,Array.of_list args)} depth s
+    | Zupdate(m)::s ->
+        strip_rec rstk (update m (h.norm,h.term)) depth s
+    | stk -> (depth,List.rev rstk, stk) in
+  strip_rec [] head 0 stk
+
+
+let rec get_nth_arg head n stk =
+  assert (head.norm <> Red);
+  let rec strip_rec rstk h depth n = function
+    | Zshift(k) as e :: s ->
+        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+    | Zapp args::s' ->
+        let q = List.length args in
+        if n >= q
+        then
+          strip_rec (Zapp args::rstk)
+            {norm=h.norm;term=FApp(h,Array.of_list args)} depth (n-q) s'
+        else
+          (match list_chop n args with
+              (bef, v::aft) -> 
+                let stk' =
+                  List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
+                (Some (stk', v), append_stack_list (aft,s'))
+            | _ -> assert false)
+    | Zupdate(m)::s ->
+        strip_rec rstk (update m (h.norm,h.term)) depth n s
+    | s -> (None, List.rev rstk @ s) in
+  strip_rec [] head 0 n stk
+
+(* Beta reduction: look for an applied argument in the stack.
+   Since the encountered update marks are removed, h must be a whnf *)
+let get_arg h stk =
+  let (depth,stk') = strip_update_shift h stk in
+  match  decomp_stack stk' with
+      Some (v, s') -> (Some (depth,v), s')
+    | None -> (None, zshift depth stk')
+
+let rec get_args n tys f e stk =
+  match stk with
+      Zupdate r :: s ->
+        let hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        get_args n tys f e s
+    | Zshift k :: s ->
+        get_args n tys f (subs_shft (k,e)) s
+    | Zapp l :: s ->
+        let na = List.length l in
+        if n == na then
+          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in
+          (Inl e',s)
+        else if n < na then (* more arguments *)
+          let (args,eargs) = list_chop n l in
+          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e args in
+          (Inl e', Zapp eargs :: s)
+        else (* more lambdas *)
+          let (_,etys) = list_chop na tys in
+          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in
+          get_args (n-na) etys f e' s
+    | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
+
+
+(* Iota reduction: extract the arguments to be passed to the Case
+   branches *)
+let rec reloc_rargs_rec depth stk =
+  match stk with
+      Zapp args :: s ->
+        Zapp (lift_fconstr_list depth args) :: reloc_rargs_rec depth s
+    | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s
+    | _ -> stk
+
+let reloc_rargs depth stk =
+  if depth = 0 then stk else reloc_rargs_rec depth stk
+
+let rec drop_parameters depth n stk =
+  match stk with
+      Zapp args::s ->
+        let q = List.length args in
+        if n > q then drop_parameters depth (n-q) s
+        else if n = q then reloc_rargs depth s
+        else
+          let aft = list_skipn n args in
+          reloc_rargs depth (append_stack_list (aft,s))
+    | Zshift(k)::s -> drop_parameters (depth-k) n s
+    | [] -> assert (n=0); []
+    | _ -> assert false (* we know that n < stack_args_size(stk) *)
+
+
+(* Iota reduction: expansion of a fixpoint.
+ * Given a fixpoint and a substitution, returns the corresponding
+ * fixpoint body, and the substitution in which it should be
+ * evaluated: its first variables are the fixpoint bodies
+ *
+ * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S)
+ *    -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti)
+ *)
+(* does not deal with FLIFT *)
+let contract_fix_vect fix =
+  let (thisbody, make_body, env, nfix) =
+    match fix with
+      | FFix (((reci,i),(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }),
+	   env, Array.length bds)
+      | FCoFix ((i,(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }),
+	   env, Array.length bds)
+      | _ -> anomaly "Closure.contract_fix_vect: not a (co)fixpoint" 
+  in
+  let rec subst_bodies_from_i i env =
+    if i = nfix then
+      (env, thisbody)
+    else
+      subst_bodies_from_i (i+1) (subs_cons (make_body i, env))
+  in       
+  subst_bodies_from_i 0 env
+
+
+(*********************************************************************)
+(* A machine that inspects the head of a term until it finds an
+   atom or a subterm that may produce a redex (abstraction,
+   constructor, cofix, letin, constant), or a neutral term (product,
+   inductive) *)
+let rec knh m stk =
+  match m.term with
+    | FLIFT(k,a) -> knh a (zshift k stk)
+    | FCLOS(t,e) -> knht e t (zupdate m stk)
+    | FLOCKED -> anomaly "Closure.knh: found lock"
+    | FApp(a,b) -> knh a (append_stack b (zupdate m stk))
+    | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk)
+    | FFix(((ri,n),(_,_,_)),_) ->
+        (match get_nth_arg m ri.(n) stk with
+             (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk')
+           | (None, stk') -> (m,stk'))
+    | FCast(t,_) -> knh t stk
+(* cases where knh stops *)
+    | (FFlex _|FLetIn _|FConstruct _|FEvar _|
+       FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
+        (m, stk)
+
+(* The same for pure terms *)
+and knht e t stk =
+  match kind_of_term t with
+    | App(a,b) ->
+        knht e a (append_stack (mk_clos_vect e b) stk)
+    | Case(ci,p,t,br) ->
+        knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk)
+    | Fix _ -> knh (mk_clos2 e t) stk
+    | Cast(a,b) -> knht e a stk
+    | Rel n -> knh (clos_rel e n) stk
+    | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
+       LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
+        (mk_clos2 e t, stk)
+
+
+(************************************************************************)
+
+(* Computes a normal form from the result of knh. *)
+let rec knr info m stk =
+  match m.term with
+  | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
+      (match get_args n tys f e stk with
+          Inl e', s -> knit info e' f s
+        | Inr lam, s -> (lam,s)) 
+  | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
+      (match ref_value_cache info (ConstKey kn) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
+      (match ref_value_cache info (VarKey id) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FFlex(FarRelKey k) when red_set info.i_flags fDELTA ->
+      (match ref_value_cache info (FarRelKey k) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FConstruct(ind,c) when red_set info.i_flags fIOTA ->
+      (match strip_update_shift_app m stk with
+          (depth, args, Zcase(ci,_,br)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            kni info br.(c-1) (rargs@s)
+        | (_, cargs, Zfix(fx,par)::s) ->
+            let rarg = fapp_stack(m,cargs) in
+            let stk' = par @ append_stack [|rarg|] s in
+            let (fxe,fxbd) = contract_fix_vect fx.term in
+            knit info fxe fxbd stk'
+        | (_,args,s) -> (m,args@s))
+  | FCoFix _ when red_set info.i_flags fIOTA ->
+      (match strip_update_shift_app m stk with
+          (_, args, ((Zcase _::_) as stk')) ->
+            let (fxe,fxbd) = contract_fix_vect m.term in
+            knit info fxe fxbd (args@stk')
+        | (_,args,s) -> (m,args@s))
+  | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA ->
+      knit info (subs_cons(v,e)) bd stk
+  | _ -> (m,stk)
+
+(* Computes the weak head normal form of a term *)
+and kni info m stk =
+  let (hm,s) = knh m stk in
+  knr info hm s
+and knit info e t stk =
+  let (ht,s) = knht e t stk in
+  knr info ht s
+
+let kh info v stk = fapp_stack(kni info v stk)
+
+(************************************************************************)
+
+let rec zip_term zfun m stk =
+  match stk with
+    | [] -> m
+    | Zapp args :: s ->
+        let args = Array.of_list args in
+        zip_term zfun (mkApp(m, Array.map zfun args)) s
+    | Zcase(ci,p,br)::s ->
+        let t = mkCase(ci, zfun p, m, Array.map zfun br) in
+        zip_term zfun t s
+    | Zfix(fx,par)::s ->
+        let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in
+        zip_term zfun h s
+    | Zshift(n)::s ->
+        zip_term zfun (lift n m) s
+    | Zupdate(rf)::s ->
+        zip_term zfun m s
+
+(* Computes the strong normal form of a term.
+   1- Calls kni
+   2- tries to rebuild the term. If a closure still has to be computed,
+      calls itself recursively. *)
+let rec kl info m =
+  if is_val m then (incr prune; term_of_fconstr m)
+  else
+    let (nm,s) = kni info m [] in
+    let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *)
+    zip_term (kl info) (norm_head info nm) s
+
+(* no redex: go up for atoms and already normalized terms, go down
+   otherwise. *) 
+and norm_head info m =
+  if is_val m then (incr prune; term_of_fconstr m) else
+    match m.term with
+      | FLambda(n,tys,f,e) ->
+          let (e',rvtys) =
+            List.fold_left (fun (e,ctxt) (na,ty) ->
+              (subs_lift e, (na,kl info (mk_clos e ty))::ctxt))
+              (e,[]) tys in
+          let bd = kl info (mk_clos e' f) in
+          List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys
+      | FLetIn(na,a,b,f,e) ->
+          let c = mk_clos (subs_lift e) f in
+          mkLetIn(na, kl info a, kl info b, kl info c)
+      | FProd(na,dom,rng) ->
+          mkProd(na, kl info dom, kl info rng)
+      | FCoFix((n,(na,tys,bds)),e) ->
+          let ftys = Array.map (mk_clos e) tys in
+          let fbds =
+            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
+          mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+      | FEvar(i,args) -> mkEvar(i, Array.map (kl info) args)
+      | t -> term_of_fconstr m
+
+(* Initialization and then normalization *)
+
+(* weak reduction *)
+let whd_val info v =
+  with_stats (lazy (term_of_fconstr (kh info v [])))
+
+(* strong reduction *)
+let norm_val info v =
+  with_stats (lazy (kl info v))
+
+let inject = mk_clos (ESID 0)
+
+let whd_stack infos m stk =
+  let k = kni infos m stk in
+  let _ = fapp_stack k in (* to unlock Zupdates! *)
+  k
+
+(* cache of constants: the body is computed only when needed. *)
+type clos_infos = fconstr infos
+
+let create_clos_infos flgs env =
+  create (fun _ -> inject) flgs env
+
+let unfold_reference = ref_value_cache
diff --git a/kernel/closure.mli b/kernel/closure.mli
new file mode 100644
index 00000000..e58b91eb
--- /dev/null
+++ b/kernel/closure.mli
@@ -0,0 +1,207 @@
+(************************************************************************)
+(*  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: closure.mli,v 1.42.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Environ
+open Esubst
+(*i*)
+
+(* Flags for profiling reductions. *)
+val stats : bool ref
+val share : bool ref
+
+val with_stats: 'a Lazy.t -> 'a
+
+(*s Delta implies all consts (both global (= by
+  [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
+  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+  a LetIn expression is Letin reduction *)
+
+type transparent_state = Idpred.t * KNpred.t
+
+val all_opaque      : transparent_state
+val all_transparent : transparent_state
+
+(* Sets of reduction kinds. *)
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+
+  (* The different kind of reduction *)
+  (* Const/Var means the reference as argument should be unfolded *)
+  (* Constbut/Varbut means all references except the ones as argument
+     of Constbut/Varbut should be unfolded (there may be several such
+     Constbut/Varbut *)
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+
+  (* No reduction at all *)
+  val no_red : reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add : reds -> red_kind -> reds
+
+  (* Removes a reduction kind to a set *)
+  val red_sub : reds -> red_kind -> reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add_transparent : reds -> transparent_state -> reds
+
+  (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
+  val mkflags : red_kind list -> reds
+
+  (* Tests if a reduction kind is set *)
+  val red_set : reds -> red_kind -> bool
+
+  (* Gives the constant list *)
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags : RedFlagsSig
+open RedFlags
+
+val beta               : reds
+val betaiota           : reds
+val betadeltaiota      : reds
+val betaiotazeta       : reds
+val betadeltaiotanolet : reds
+
+val unfold_red : evaluable_global_reference -> reds
+
+(************************************************************************)
+
+type table_key =
+  | ConstKey of constant
+  | VarKey of identifier
+  | FarRelKey of int
+   (* FarRel: index in the [rel_context] part of {\em initial} environment *)
+
+type 'a infos
+val ref_value_cache: 'a infos -> table_key -> 'a option
+val info_flags: 'a infos -> reds
+val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos
+
+(************************************************************************)
+(*s A [stack] is a context of arguments, arguments are pushed by
+   [append_stack] one array at a time but popped with [decomp_stack]
+   one by one *)
+
+type 'a stack_member =
+  | Zapp of 'a list
+  | Zcase of case_info * 'a * 'a array
+  | Zfix of 'a * 'a stack
+  | Zshift of int
+  | Zupdate of 'a
+
+and 'a stack = 'a stack_member list
+
+val empty_stack : 'a stack
+val append_stack : 'a array -> 'a stack -> 'a stack
+
+val decomp_stack : 'a stack -> ('a * 'a stack) option
+val list_of_stack : 'a stack -> 'a list
+val array_of_stack : 'a stack -> 'a array
+val stack_assign : 'a stack -> int -> 'a -> 'a stack
+val stack_args_size : 'a stack -> int
+val app_stack : constr * constr stack -> constr
+val stack_tail : int -> 'a stack -> 'a stack
+val stack_nth : 'a stack -> int -> 'a
+
+(************************************************************************)
+(*s Lazy reduction. *)
+
+(* [fconstr] is the type of frozen constr *)
+
+type fconstr
+
+(* [fconstr] can be accessed by using the function [fterm_of] and by
+   matching on type [fterm] *)
+
+type fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * fconstr
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+(* To lazy reduce a constr, create a [clos_infos] with
+   [create_clos_infos], inject the term to reduce with [inject]; then use
+   a reduction function *)
+
+val inject : constr -> fconstr
+val fterm_of : fconstr -> fterm
+val term_of_fconstr : fconstr -> constr
+val destFLambda :
+  (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+
+(* Global and local constant cache *)
+type clos_infos
+val create_clos_infos : reds -> env -> clos_infos
+
+(* Reduction function *)
+
+(* [norm_val] is for strong normalization *)
+val norm_val : clos_infos -> fconstr -> constr
+
+(* [whd_val] is for weak head normalization *)
+val whd_val : clos_infos -> fconstr -> constr
+
+(* [whd_stack] performs weak head normalization in a given stack. It
+   stops whenever a reduction is blocked. *)
+val whd_stack :
+  clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
+
+(* Conversion auxiliary functions to do step by step normalisation *)
+
+(* [unfold_reference] unfolds references in a [fconstr] *)
+val unfold_reference : clos_infos -> table_key -> fconstr option
+
+(* [mind_equiv] checks whether two mutual inductives are intentionally equal *)
+val mind_equiv : clos_infos -> mutual_inductive -> mutual_inductive -> bool
+
+(************************************************************************)
+(*i This is for lazy debug *)
+
+val lift_fconstr      : int -> fconstr -> fconstr
+val lift_fconstr_vect : int -> fconstr array -> fconstr array
+
+val mk_clos      : fconstr subs -> constr -> fconstr
+val mk_clos_vect : fconstr subs -> constr array -> fconstr array
+val mk_clos_deep :
+  (fconstr subs -> constr -> fconstr) ->
+   fconstr subs -> constr -> fconstr
+
+val kni: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
+val knr: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
+val kl : clos_infos -> fconstr -> constr
+
+val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
+val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
+
+(* End of cbn debug section i*)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
new file mode 100644
index 00000000..dba373ce
--- /dev/null
+++ b/kernel/conv_oracle.ml
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  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: conv_oracle.ml,v 1.2.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+
+open Names
+open Closure
+
+(* Opaque constants *)
+let cst_transp = ref KNpred.full
+
+let set_opaque_const kn = cst_transp := KNpred.remove kn !cst_transp
+let set_transparent_const kn = cst_transp := KNpred.add kn !cst_transp
+
+let is_opaque_cst kn = not (KNpred.mem kn !cst_transp)
+
+(* Opaque variables *)
+let var_transp = ref Idpred.full
+
+let set_opaque_var kn = var_transp := Idpred.remove kn !var_transp
+let set_transparent_var kn = var_transp := Idpred.add kn !var_transp
+
+let is_opaque_var kn = not (Idpred.mem kn !var_transp)
+
+(* Opaque reference keys *)
+let is_opaque = function
+  | ConstKey cst -> is_opaque_cst cst
+  | VarKey id -> is_opaque_var id
+  | FarRelKey _ -> false
+
+(* Unfold the first only if it is not opaque and the second is opaque *)
+let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1)
+
+(* summary operations *)
+
+let init() = (cst_transp := KNpred.full; var_transp := Idpred.full)
+let freeze () = (!var_transp, !cst_transp)
+let unfreeze (vo,co) = (cst_transp := co; var_transp := vo)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
new file mode 100644
index 00000000..77de9b8a
--- /dev/null
+++ b/kernel/conv_oracle.mli
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*  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: conv_oracle.mli,v 1.3.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+
+open Names
+open Closure
+
+(* Order on section paths for unfolding.
+   If [oracle_order kn1 kn2] is true, then unfold kn1 first.
+   Note: the oracle does not introduce incompleteness, it only
+   tries to postpone unfolding of "opaque" constants. *)
+val oracle_order : table_key -> table_key -> bool
+
+(* Changing the oracle *)
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
+
+val set_opaque_var      : identifier -> unit
+val set_transparent_var : identifier -> unit
+
+val is_opaque_cst : constant -> bool
+val is_opaque_var : identifier -> bool
+
+(*****************************)
+
+(* transparent state summary operations *)
+val init     : unit -> unit
+val freeze   : unit -> transparent_state
+val unfreeze : transparent_state -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
new file mode 100644
index 00000000..d69efe3a
--- /dev/null
+++ b/kernel/cooking.ml
@@ -0,0 +1,172 @@
+(************************************************************************)
+(*  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: cooking.ml,v 1.17.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Declarations
+open Environ
+open Reduction
+
+(*s Cooking the constants. *)
+
+type 'a modification =
+  | NOT_OCCUR
+  | DO_ABSTRACT of 'a * constr array
+  | DO_REPLACE of constant_body
+
+type work_list =
+    (constant * constant modification) list
+    * (inductive * inductive modification) list
+    * (constructor * constructor modification) list
+
+type recipe = {
+  d_from : constant_body;
+  d_abstract : identifier list;
+  d_modlist : work_list }
+
+let failure () =
+  anomalylabstrm "generic__modify_opers"
+    (str"An oper which was never supposed to appear has just appeared" ++
+     spc () ++ str"Either this is in system code, and you need to" ++ spc () ++
+     str"report this error," ++ spc () ++
+     str"Or you are using a user-written tactic which calls" ++ spc () ++
+     str"generic__modify_opers, in which case the user-written code" ++
+     spc () ++ str"is broken - this function is an internal system" ++
+     spc () ++ str"for internal system use only")
+
+let modify_opers replfun (constl,indl,cstrl) =
+  let rec substrec c =
+    let c' = map_constr substrec c in
+    match kind_of_term c' with
+      | Case (ci,p,t,br) ->
+	  (try
+	     match List.assoc ci.ci_ind indl with
+	       | DO_ABSTRACT (ind,abs_vars) ->
+		   let n' = Array.length abs_vars + ci.ci_npar in
+                   let ci' = { ci with
+                               ci_ind = ind;
+                               ci_npar = n' } in
+		   mkCase (ci',p,t,br)
+	       | _ -> raise Not_found
+	   with
+	     | Not_found -> c')
+
+      | Ind spi ->
+	  (try
+	     (match List.assoc spi indl with
+		| NOT_OCCUR -> failure ()
+		| DO_ABSTRACT (oper',abs_vars) ->
+                    mkApp (mkInd oper', abs_vars)
+		| DO_REPLACE _ -> assert false)
+	   with 
+	     | Not_found -> c')
+
+      | Construct spi ->
+	  (try
+	     (match List.assoc spi cstrl with
+		| NOT_OCCUR -> failure ()
+		| DO_ABSTRACT (oper',abs_vars) ->
+		    mkApp (mkConstruct oper', abs_vars)
+		| DO_REPLACE _ -> assert false)
+	   with 
+	     | Not_found -> c')
+
+      | Const kn ->
+	  (try
+	     (match List.assoc kn constl with
+		| NOT_OCCUR -> failure ()
+		| DO_ABSTRACT (oper',abs_vars) ->
+		    mkApp (mkConst oper', abs_vars)
+		| DO_REPLACE cb -> substrec (replfun (kn,cb)))
+	   with 
+	     | Not_found -> c')
+  
+    | _ -> c'
+  in 
+  if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec
+
+let expmod_constr modlist c =
+  let simpfun = 
+    if modlist = ([],[],[]) then fun x -> x else nf_betaiota in
+  let expfun (kn,cb) = 
+    if cb.const_opaque then
+      errorlabstrm "expmod_constr"
+	(str"Cannot unfold the value of " ++
+        str(string_of_kn kn) ++ spc () ++
+        str"You cannot declare local lemmas as being opaque" ++ spc () ++
+        str"and then require that theorems which use them" ++ spc () ++
+        str"be transparent");
+    match cb.const_body with
+      | Some body -> Declarations.force body
+      | None -> assert false
+  in
+  let c' = modify_opers expfun modlist c in
+  match kind_of_term c' with
+    | Cast (value,typ) -> mkCast (simpfun value,simpfun typ)
+    | _ -> simpfun c'
+
+let expmod_type modlist c =
+  type_app (expmod_constr modlist) c
+
+let abstract_constant ids_to_abs hyps (body,typ) =
+  let abstract_once_typ ((hyps,typ) as sofar) id =
+    match hyps with
+      | (hyp,c,t as decl)::rest when hyp = id ->
+	  let typ' = mkNamedProd_wo_LetIn decl typ in
+	  (rest, typ')
+      | _ -> 
+	  sofar
+  in
+  let abstract_once_body ((hyps,body) as sofar) id =
+    match hyps with
+      | (hyp,c,t as decl)::rest when hyp = id ->
+	  let body' = mkNamedLambda_or_LetIn decl body in
+	  (rest, body')
+      | _ -> 
+	  sofar
+  in
+  let (_,typ') =
+    List.fold_left abstract_once_typ (hyps,typ) ids_to_abs 
+  in
+  let body' = match body with
+      None -> None
+    | Some l_body -> 
+	Some (Declarations.from_val
+		(let body = Declarations.force l_body in
+		 let (_,body') = 
+		   List.fold_left abstract_once_body (hyps,body) ids_to_abs
+		 in
+		   body'))
+  in
+    (body',typ')
+
+let cook_constant env r =
+  let cb = r.d_from in
+  let typ = expmod_type r.d_modlist cb.const_type in
+  let body = 
+    option_app 
+      (fun lconstr -> 
+	 Declarations.from_val 
+	   (expmod_constr r.d_modlist (Declarations.force lconstr))) 
+      cb.const_body
+  in
+  let hyps =
+    Sign.fold_named_context
+      (fun d ctxt ->
+        Sign.add_named_decl
+          (map_named_declaration (expmod_constr r.d_modlist) d)
+          ctxt)
+      cb.const_hyps
+      ~init:empty_named_context in
+  let body,typ = abstract_constant r.d_abstract hyps (body,typ) in
+  (body, typ, cb.const_constraints, cb.const_opaque)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
new file mode 100644
index 00000000..54526e99
--- /dev/null
+++ b/kernel/cooking.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: cooking.mli,v 1.9.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Univ
+
+(*s Cooking the constants. *)
+
+type 'a modification =
+  | NOT_OCCUR
+  | DO_ABSTRACT of 'a * constr array
+  | DO_REPLACE of constant_body
+
+type work_list =
+    (constant * constant modification) list
+    * (inductive * inductive modification) list
+    * (constructor * constructor modification) list
+
+type recipe = {
+  d_from : constant_body;
+  d_abstract : identifier list;
+  d_modlist : work_list }
+
+val cook_constant :
+  env -> recipe -> constr_substituted option * constr * constraints * bool
+
+(*s Utility functions used in module [Discharge]. *)
+
+val expmod_constr : work_list -> constr -> constr
+val expmod_type : work_list -> types -> types
+
+
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
new file mode 100644
index 00000000..8943b0b5
--- /dev/null
+++ b/kernel/declarations.ml
@@ -0,0 +1,193 @@
+(************************************************************************)
+(*  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: declarations.ml,v 1.31.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the types of global declarations. This includes
+   global constants/axioms and mutual inductive definitions *)
+
+(*s Constants (internal representation) (Definition/Axiom) *)
+
+type subst_internal = 
+  | Constr of constr 
+  | LazyConstr of substitution * constr
+
+type constr_substituted = subst_internal ref
+
+let from_val c = ref (Constr c)
+
+let force cs = match !cs with
+    Constr c -> c
+  | LazyConstr (subst,c) -> 
+      let c' = subst_mps subst c in
+	cs := Constr c';
+	c'
+
+let subst_constr_subst subst cs = match !cs with
+    Constr c -> ref (LazyConstr (subst,c))
+  | LazyConstr (subst',c) -> 
+      let subst'' = join subst' subst in
+	ref (LazyConstr (subst'',c))
+
+type constant_body = {
+  const_hyps : section_context; (* New: younger hyp at top *)
+  const_body : constr_substituted option;
+  const_type : types;
+  const_constraints : constraints;
+  const_opaque : bool }
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+let subst_recarg sub r = match r with
+  | Norec | Mrec _  -> r
+  | Imbr (kn,i) -> let kn' = subst_kn sub kn in
+      if kn==kn' then r else Imbr (kn',i)
+
+type wf_paths = recarg Rtree.t
+
+let mk_norec = Rtree.mk_node Norec [||]
+
+let mk_paths r recargs =
+  Rtree.mk_node r
+    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
+
+let dest_recarg p = fst (Rtree.dest_node p)
+
+let dest_subterms p =
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
+
+let recarg_length p j = 
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
+
+let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
+
+(* [mind_typename] is the name of the inductive; [mind_arity] is
+   the arity generalized over global parameters; [mind_lc] is the list
+   of types of constructors generalized over global parameters and
+   relative to the global context enriched with the arities of the
+   inductives *) 
+
+type one_inductive_body = {
+  mind_typename : identifier;
+  mind_nparams : int;
+  mind_params_ctxt : rel_context;
+  mind_nrealargs : int;
+  mind_nf_arity : types;
+  mind_user_arity : types;
+  mind_sort : sorts;
+  mind_kelim : sorts_family list;
+  mind_consnames : identifier array;
+  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
+  mind_user_lc : types array;
+  mind_recargs : wf_paths;
+ }
+
+type mutual_inductive_body = {
+  mind_finite : bool;
+  mind_ntypes : int;
+  mind_hyps : section_context;
+  mind_packets : one_inductive_body array;
+  mind_constraints : constraints;
+  mind_equiv : kernel_name option
+ }
+
+(* TODO: should be changed to non-coping after Term.subst_mps *)
+let subst_const_body sub cb = 
+  { const_body = option_app (subst_constr_subst sub) cb.const_body;
+    const_type = type_app (Term.subst_mps sub) cb.const_type;
+    const_hyps = (assert (cb.const_hyps=[]); []);
+    const_constraints = cb.const_constraints;
+    const_opaque = cb.const_opaque}
+  
+let subst_mind_packet sub mbp = 
+  { mind_consnames = mbp.mind_consnames;
+    mind_typename = mbp.mind_typename;
+    mind_nf_lc = 
+      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_nf_lc;
+    mind_nf_arity = type_app (Term.subst_mps sub) mbp.mind_nf_arity;
+    mind_user_lc = 
+      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_user_lc;
+    mind_user_arity = type_app (Term.subst_mps sub) mbp.mind_user_arity;
+    mind_sort = mbp.mind_sort;
+    mind_nrealargs = mbp.mind_nrealargs;
+    mind_kelim = mbp.mind_kelim;
+    mind_nparams = mbp.mind_nparams;
+    mind_params_ctxt = 
+      map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt;
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
+}
+
+let subst_mind sub mib = 
+  { mind_finite = mib.mind_finite ;
+    mind_ntypes = mib.mind_ntypes ;
+    mind_hyps = (assert (mib.mind_hyps=[]); []) ;
+    mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
+    mind_constraints = mib.mind_constraints ;
+    mind_equiv = option_app (subst_kn sub) mib.mind_equiv;
+}
+
+
+(*s Modules: signature component specifications, module types, and
+  module declarations *)
+
+type specification_body = 
+  | SPBconst of constant_body
+  | SPBmind of mutual_inductive_body
+  | SPBmodule of module_specification_body
+  | SPBmodtype of module_type_body
+
+and module_signature_body = (label * specification_body) list
+
+and module_type_body = 
+  | MTBident of kernel_name
+  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
+  | MTBsig of mod_self_id * module_signature_body
+
+and module_specification_body = 
+    { msb_modtype : module_type_body;
+      msb_equiv : module_path option; 
+      msb_constraints : constraints }
+
+
+type structure_elem_body = 
+  | SEBconst of constant_body
+  | SEBmind of mutual_inductive_body
+  | SEBmodule of module_body
+  | SEBmodtype of module_type_body
+
+and module_structure_body = (label * structure_elem_body) list
+
+and module_expr_body =
+  | MEBident of module_path
+  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
+  | MEBstruct of mod_self_id * module_structure_body
+  | MEBapply of module_expr_body * module_expr_body
+      * constraints
+
+and module_body = 
+    { mod_expr : module_expr_body option;
+      mod_user_type : module_type_body option;
+      mod_type : module_type_body;
+      mod_equiv : module_path option;
+      mod_constraints : constraints }
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
new file mode 100644
index 00000000..3252ddee
--- /dev/null
+++ b/kernel/declarations.mli
@@ -0,0 +1,141 @@
+(************************************************************************)
+(*  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: declarations.mli,v 1.33.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the internal representation of global
+   declarations. This includes global constants/axioms, mutual
+   inductive definitions, modules and module types *)
+
+(*s Constants (Definition/Axiom) *)
+
+type constr_substituted
+
+val from_val : constr -> constr_substituted
+val force : constr_substituted -> constr
+
+type constant_body = {
+  const_hyps : section_context; (* New: younger hyp at top *)
+  const_body : constr_substituted option;
+  const_type : types;
+  const_constraints : constraints;
+  const_opaque : bool }
+
+val subst_const_body : substitution -> constant_body -> constant_body
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+val subst_recarg : substitution -> recarg -> recarg
+
+type wf_paths = recarg Rtree.t
+
+val mk_norec : wf_paths
+val mk_paths : recarg -> wf_paths list array -> wf_paths
+val dest_recarg : wf_paths -> recarg
+val dest_subterms : wf_paths -> wf_paths list array
+val recarg_length : wf_paths -> int -> int
+
+val subst_wf_paths : substitution -> wf_paths -> wf_paths
+
+(* [mind_typename] is the name of the inductive; [mind_arity] is
+   the arity generalized over global parameters; [mind_lc] is the list
+   of types of constructors generalized over global parameters and
+   relative to the global context enriched with the arities of the
+   inductives *) 
+
+type one_inductive_body = {
+  mind_typename : identifier;
+  mind_nparams : int;
+  mind_params_ctxt : rel_context;
+  mind_nrealargs : int;
+  mind_nf_arity : types;
+  mind_user_arity : types;
+  mind_sort : sorts;
+  mind_kelim : sorts_family list;
+  mind_consnames : identifier array;
+  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
+  mind_user_lc : types array;
+  mind_recargs : wf_paths;
+ }
+
+type mutual_inductive_body = {
+  mind_finite : bool;
+  mind_ntypes : int;
+  mind_hyps : section_context;
+  mind_packets : one_inductive_body array;
+  mind_constraints : constraints;
+  mind_equiv : kernel_name option;
+ }
+
+
+val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
+
+
+(*s Modules: signature component specifications, module types, and
+  module declarations *)
+
+type specification_body = 
+  | SPBconst of constant_body
+  | SPBmind of mutual_inductive_body
+  | SPBmodule of module_specification_body
+  | SPBmodtype of module_type_body
+
+and module_signature_body = (label * specification_body) list
+
+and module_type_body = 
+  | MTBident of kernel_name
+  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
+  | MTBsig of mod_self_id * module_signature_body
+
+and module_specification_body = 
+    { msb_modtype : module_type_body;
+      msb_equiv : module_path option; 
+      msb_constraints : constraints }
+    (*    type_of(equiv) <: modtype  (if given)  
+       +  substyping of past With_Module mergers *)
+
+
+type structure_elem_body = 
+  | SEBconst of constant_body
+  | SEBmind of mutual_inductive_body
+  | SEBmodule of module_body
+  | SEBmodtype of module_type_body
+
+and module_structure_body = (label * structure_elem_body) list
+
+and module_expr_body =
+  | MEBident of module_path
+  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
+  | MEBstruct of mod_self_id * module_structure_body
+  | MEBapply of module_expr_body * module_expr_body  (* (F A) *)
+      * constraints  (* type_of(A) <: input_type_of(F) *)
+
+and module_body = 
+    { mod_expr : module_expr_body option;
+      mod_user_type : module_type_body option;
+      mod_type : module_type_body;
+      mod_equiv : module_path option;
+      mod_constraints : constraints }
+    (*    type_of(mod_expr)  <: mod_user_type (if given)  *)
+    (*  if equiv given then constraints are empty *)
+
+
+
diff --git a/kernel/doc.tex b/kernel/doc.tex
new file mode 100644
index 00000000..4a9fc355
--- /dev/null
+++ b/kernel/doc.tex
@@ -0,0 +1,11 @@
+
+\newpage
+\section*{The Coq kernel}
+
+\ocwsection \label{kernel}
+This chapter describes the \Coq\ kernel, which is a type checker for the \CCI.
+The modules of the kernel are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=kernel.dep.ps,width=\linewidth}\end{center}
+
diff --git a/kernel/entries.ml b/kernel/entries.ml
new file mode 100644
index 00000000..d833499e
--- /dev/null
+++ b/kernel/entries.ml
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  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: entries.ml,v 1.3.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the entry types for global declarations. This
+   information is entered in the environments. This includes global
+   constants/axioms, mutual inductive definitions, modules and module
+   types *)
+
+
+(*s Local entries *)
+
+type local_entry =
+  | LocalDef of constr
+  | LocalAssum of constr
+
+
+(*s Declaration of inductive types. *)
+
+(* Assume the following definition in concrete syntax:
+\begin{verbatim}
+Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+...
+with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+\end{verbatim}
+then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
+[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
+[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
+*)
+
+type one_inductive_entry = {
+  mind_entry_params : (identifier * local_entry) list;
+  mind_entry_typename : identifier;
+  mind_entry_arity : constr;
+  mind_entry_consnames : identifier list;
+  mind_entry_lc : constr list }
+
+type mutual_inductive_entry = {
+  mind_entry_finite : bool;
+  mind_entry_inds : one_inductive_entry list }
+
+
+(*s Constants (Definition/Axiom) *)
+
+type definition_entry = {
+  const_entry_body   : constr;
+  const_entry_type   : types option;
+  const_entry_opaque : bool }
+
+type parameter_entry = types
+
+type constant_entry = 
+  | DefinitionEntry of definition_entry
+  | ParameterEntry of parameter_entry
+
+(*s Modules *)
+
+type specification_entry = 
+    SPEconst of constant_entry
+  | SPEmind of mutual_inductive_entry
+  | SPEmodule of module_entry
+  | SPEmodtype of module_type_entry
+
+and module_type_entry = 
+    MTEident of kernel_name
+  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
+  | MTEsig of mod_self_id * module_signature_entry
+  | MTEwith of module_type_entry * with_declaration
+
+and module_signature_entry = (label * specification_entry) list
+
+and with_declaration = 
+    With_Module of identifier * module_path
+  | With_Definition of identifier * constr
+
+and module_expr = 
+    MEident of module_path
+  | MEfunctor of mod_bound_id * module_type_entry * module_expr
+  | MEstruct of mod_self_id * module_structure
+  | MEapply of module_expr * module_expr
+
+and module_structure = (label * specification_entry) list
+
+
+and module_entry = 
+    { mod_entry_type : module_type_entry option;
+      mod_entry_expr : module_expr option}
+
diff --git a/kernel/entries.mli b/kernel/entries.mli
new file mode 100644
index 00000000..edade51a
--- /dev/null
+++ b/kernel/entries.mli
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  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: entries.mli,v 1.3.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the entry types for global declarations. This
+   information is entered in the environments. This includes global
+   constants/axioms, mutual inductive definitions, modules and module
+   types *)
+
+
+(*s Local entries *)
+
+type local_entry =
+  | LocalDef of constr
+  | LocalAssum of constr
+
+
+(*s Declaration of inductive types. *)
+
+(* Assume the following definition in concrete syntax:
+\begin{verbatim}
+Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+...
+with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+\end{verbatim}
+then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
+[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
+[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
+*)
+
+type one_inductive_entry = {
+  mind_entry_params : (identifier * local_entry) list;
+  mind_entry_typename : identifier;
+  mind_entry_arity : constr;
+  mind_entry_consnames : identifier list;
+  mind_entry_lc : constr list }
+
+type mutual_inductive_entry = {
+  mind_entry_finite : bool;
+  mind_entry_inds : one_inductive_entry list }
+
+
+(*s Constants (Definition/Axiom) *)
+
+type definition_entry = {
+  const_entry_body   : constr;
+  const_entry_type   : types option;
+  const_entry_opaque : bool }
+
+type parameter_entry = types
+
+type constant_entry = 
+  | DefinitionEntry of definition_entry
+  | ParameterEntry of parameter_entry
+
+(*s Modules *)
+
+type specification_entry = 
+    SPEconst of constant_entry
+  | SPEmind of mutual_inductive_entry
+  | SPEmodule of module_entry
+  | SPEmodtype of module_type_entry
+
+and module_type_entry = 
+    MTEident of kernel_name
+  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
+  | MTEsig of mod_self_id * module_signature_entry
+  | MTEwith of module_type_entry * with_declaration
+
+and module_signature_entry = (label * specification_entry) list
+
+and with_declaration = 
+    With_Module of identifier * module_path
+  | With_Definition of identifier * constr
+
+and module_expr = 
+    MEident of module_path
+  | MEfunctor of mod_bound_id * module_type_entry * module_expr
+  | MEstruct of mod_self_id * module_structure
+  | MEapply of module_expr * module_expr
+
+and module_structure = (label * specification_entry) list
+
+
+and module_entry = 
+    { mod_entry_type : module_type_entry option;
+      mod_entry_expr : module_expr option}
+
diff --git a/kernel/environ.ml b/kernel/environ.ml
new file mode 100644
index 00000000..ec3c903d
--- /dev/null
+++ b/kernel/environ.ml
@@ -0,0 +1,295 @@
+(************************************************************************)
+(*  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: environ.ml,v 1.89.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+type checksum = int
+
+type compilation_unit_name = dir_path * checksum
+
+type global = Constant | Inductive
+
+type engagement = ImpredicativeSet
+
+type globals = {
+  env_constants : constant_body KNmap.t;
+  env_inductives : mutual_inductive_body KNmap.t;
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body KNmap.t }
+
+type stratification = {
+  env_universes : universes;
+  env_engagement : engagement option
+}
+
+type env = {
+  env_globals        : globals;
+  env_named_context  : named_context;
+  env_rel_context    : rel_context;
+  env_stratification : stratification }
+
+let empty_env = { 
+  env_globals = {
+    env_constants = KNmap.empty;
+    env_inductives = KNmap.empty;
+    env_modules = MPmap.empty;
+    env_modtypes = KNmap.empty };
+  env_named_context = empty_named_context;
+  env_rel_context = empty_rel_context;
+  env_stratification = {
+    env_universes = initial_universes;
+    env_engagement = None } }
+
+let engagement env = env.env_stratification.env_engagement
+let universes env = env.env_stratification.env_universes
+let named_context env = env.env_named_context
+let rel_context env = env.env_rel_context
+
+let empty_context env = 
+  env.env_rel_context = empty_rel_context 
+  && env.env_named_context = empty_named_context
+
+(* Rel context *)
+let lookup_rel n env =
+  Sign.lookup_rel n env.env_rel_context
+
+let evaluable_rel n env =
+  try
+    match lookup_rel n env with
+        (_,Some _,_) -> true
+      | _ -> false
+  with Not_found -> 
+    false
+
+let push_rel d env =
+  { env with
+      env_rel_context = add_rel_decl d env.env_rel_context }
+
+let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
+let push_rec_types (lna,typarray,_) env =
+  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 -> push_rel assum e) env ctxt
+
+let reset_rel_context env =
+  { env with
+      env_rel_context = empty_rel_context }
+
+let fold_rel_context f env ~init =
+  snd (Sign.fold_rel_context
+	 (fun d (env,e) -> (push_rel d env, f env d e))
+         (rel_context env) ~init:(reset_rel_context env,init))
+
+
+(* Named context *)
+let lookup_named id env =
+  Sign.lookup_named id env.env_named_context
+
+(* A local const is evaluable if it is defined and not opaque *)
+let evaluable_named id env =
+  try 
+    match lookup_named id env with
+        (_,Some _,_) -> true
+      | _ -> false
+  with Not_found -> 
+    false
+
+let push_named d env =
+  { env with
+      env_named_context = Sign.add_named_decl d env.env_named_context }
+
+let reset_context env =
+  { env with
+      env_named_context = empty_named_context;
+      env_rel_context = empty_rel_context }
+
+let reset_with_named_context ctxt env =
+  { env with
+      env_named_context = ctxt;
+      env_rel_context = empty_rel_context }
+
+let fold_named_context f env ~init =
+  snd (Sign.fold_named_context
+	 (fun d (env,e) -> (push_named d env, f env d e))
+         (named_context env) ~init:(reset_context env,init))
+
+let fold_named_context_reverse f ~init env =
+  Sign.fold_named_context_reverse f ~init:init (named_context env) 
+
+(* Global constants *)
+let lookup_constant kn env =
+  KNmap.find kn env.env_globals.env_constants
+
+let add_constant kn cb env =
+  let new_constants = KNmap.add kn cb env.env_globals.env_constants in
+  let new_globals = 
+    { env.env_globals with 
+	env_constants = new_constants } in 
+  { env with env_globals = new_globals }
+
+(* constant_type gives the type of a constant *)
+let constant_type env kn =
+  let cb = lookup_constant kn env in
+  cb.const_type  
+
+type const_evaluation_result = NoBody | Opaque
+
+exception NotEvaluableConst of const_evaluation_result
+
+let constant_value env kn =
+  let cb = lookup_constant kn env in
+  if cb.const_opaque then raise (NotEvaluableConst Opaque);
+  match cb.const_body with
+    | Some l_body -> Declarations.force l_body
+    | None -> raise (NotEvaluableConst NoBody)
+
+let constant_opt_value env cst =
+  try Some (constant_value env cst)
+  with NotEvaluableConst _ -> None
+
+(* A global const is evaluable if it is defined and not opaque *)
+let evaluable_constant cst env =
+  try let _  = constant_value env cst in true
+  with Not_found | NotEvaluableConst _ -> false
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  KNmap.find kn env.env_globals.env_inductives
+
+let add_mind kn mib env =
+  let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
+  let new_globals = 
+    { env.env_globals with 
+	env_inductives = new_inds } in
+  { env with env_globals = new_globals }
+
+(* Universe constraints *)
+let set_universes g env =
+  if env.env_stratification.env_universes == g then env
+  else
+    { env with env_stratification = 
+      { env.env_stratification with env_universes = g } }
+
+let add_constraints c env =
+  if c == Constraint.empty then 
+    env 
+  else
+    let s = env.env_stratification in
+    { env with env_stratification = 
+      { s with env_universes = merge_constraints c s.env_universes } }
+
+let set_engagement c env = (* Unsafe *)
+  { env with env_stratification =
+    { env.env_stratification with env_engagement = Some c } }
+
+(* Lookup of section variables *)
+let lookup_constant_variables c env =
+  let cmap = lookup_constant c env in
+  Sign.vars_of_named_context cmap.const_hyps
+
+let lookup_inductive_variables (kn,i) env =
+  let mis = lookup_mind kn env in
+  Sign.vars_of_named_context mis.mind_hyps
+
+let lookup_constructor_variables (ind,_) env =
+  lookup_inductive_variables ind env
+
+(* Returns the list of global variables in a term *)
+
+let vars_of_global env constr =
+  match kind_of_term constr with
+      Var id -> [id]
+    | Const kn -> lookup_constant_variables kn env
+    | Ind ind -> lookup_inductive_variables ind env
+    | Construct cstr -> lookup_constructor_variables cstr env
+    | _ -> []
+
+let global_vars_set env constr = 
+  let rec filtrec acc c =
+    let vl = vars_of_global env c in
+    let acc = List.fold_right Idset.add vl acc in
+    fold_constr filtrec acc c
+  in 
+  filtrec Idset.empty constr
+
+(* [keep_hyps env ids] keeps the part of the section context of [env] which 
+   contains the variables of the set [ids], and recursively the variables 
+   contained in the types of the needed variables. *)
+
+let keep_hyps env needed =
+  let really_needed =
+    Sign.fold_named_context_reverse
+      (fun need (id,copt,t) ->
+        if Idset.mem id need then
+          let globc = 
+	    match copt with
+	      | None -> Idset.empty
+	      | Some c -> global_vars_set env c in
+	  Idset.union
+            (global_vars_set env t) 
+	    (Idset.union globc need)
+        else need)
+      ~init:needed
+      (named_context env) in
+  Sign.fold_named_context
+    (fun (id,_,_ as d) nsign ->
+      if Idset.mem id really_needed then add_named_decl d nsign
+      else nsign)
+    (named_context env)
+    ~init:empty_named_context
+
+
+(* Modules *)
+
+let add_modtype ln mtb env = 
+  let new_modtypes = KNmap.add ln mtb env.env_globals.env_modtypes in
+  let new_globals = 
+    { env.env_globals with 
+	env_modtypes = new_modtypes } in
+  { env with env_globals = new_globals }
+
+let shallow_add_module mp mb env = 
+  let new_mods = MPmap.add mp mb env.env_globals.env_modules in
+  let new_globals = 
+    { env.env_globals with 
+	env_modules = new_mods } in
+  { env with env_globals = new_globals }
+
+let lookup_module mp env = 
+  MPmap.find mp env.env_globals.env_modules
+
+let lookup_modtype ln env = 
+  KNmap.find ln env.env_globals.env_modtypes
+
+(*s Judgments. *)
+
+type unsafe_judgment = { 
+  uj_val : constr;
+  uj_type : types }
+
+let make_judge v tj =
+  { uj_val = v;
+    uj_type = tj }
+
+let j_val j = j.uj_val
+let j_type j = j.uj_type
+
+type unsafe_type_judgment = { 
+  utj_val : constr;
+  utj_type : sorts }
+
diff --git a/kernel/environ.mli b/kernel/environ.mli
new file mode 100644
index 00000000..4e54761b
--- /dev/null
+++ b/kernel/environ.mli
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  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: environ.mli,v 1.66.2.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Sign
+(*i*)
+
+(*s Unsafe environments. We define here a datatype for environments. 
+   Since typing is not yet defined, it is not possible to check the
+   informations added in environments, and that is why we speak here
+   of ``unsafe'' environments. *)
+
+(* Environments have the following components:
+   - a context for de Bruijn variables
+   - a context for section variables and goal assumptions
+   - a context for global constants and axioms
+   - a context for inductive definitions
+   - a set of universe constraints
+   - a flag telling if Set is, can be, or cannot be set impredicative *)
+
+type env
+
+val empty_env : env
+
+val universes     : env -> Univ.universes
+val rel_context   : env -> rel_context
+val named_context : env -> named_context
+
+type engagement = ImpredicativeSet
+
+val engagement    : env -> engagement option
+
+(* is the local context empty *)
+val empty_context : env -> bool
+
+(************************************************************************)
+(*s Context of de Bruijn variables (rel_context) *)
+val push_rel         : rel_declaration -> env -> env
+val push_rel_context :     rel_context -> env -> env
+val push_rec_types   : rec_declaration -> env -> env
+
+(* Looks up in the context of local vars referred by indice ([rel_context]) *)
+(* raises [Not_found] if the index points out of the context *)
+val lookup_rel    : int -> env -> rel_declaration
+val evaluable_rel : int -> env -> bool
+
+(*s Recurrence on [rel_context] *)
+val fold_rel_context :
+  (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+
+(************************************************************************)
+(* Context of variables (section variables and goal assumptions) *)
+val push_named : named_declaration -> env -> env
+
+(* Looks up in the context of local vars referred by names ([named_context]) *)
+(* raises [Not_found] if the identifier is not found *)
+val lookup_named    : variable -> env -> named_declaration
+val evaluable_named : variable -> env -> bool
+
+(*s Recurrence on [named_context]: older declarations processed first *)
+val fold_named_context :
+  (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+
+(* Recurrence on [named_context] starting from younger decl *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a
+
+(* This forgets named and rel contexts *)
+val reset_context : env -> env
+(* This forgets rel context and sets a new named context *)
+val reset_with_named_context : named_context -> env -> env
+
+(************************************************************************)
+(*s Global constants *)
+(*s Add entries to global environment *)
+val add_constant : constant -> constant_body -> env -> env
+
+(* Looks up in the context of global constant names *)
+(* raises [Not_found] if the required path is not found *)
+val lookup_constant    : constant -> env -> constant_body
+val evaluable_constant : constant -> env -> bool
+
+(*s [constant_value env c] raises [NotEvaluableConst Opaque] if
+   [c] is opaque and [NotEvaluableConst NoBody] if it has no
+   body and [Not_found] if it does not exist in [env] *)
+type const_evaluation_result = NoBody | Opaque
+exception NotEvaluableConst of const_evaluation_result
+
+val constant_value     : env -> constant -> constr
+val constant_type      : env -> constant -> types
+val constant_opt_value : env -> constant -> constr option
+
+(************************************************************************)
+(*s Inductive types *)
+val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
+
+(* Looks up in the context of global inductive names *)
+(* raises [Not_found] if the required path is not found *)
+val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
+
+(************************************************************************)
+(*s Modules *)
+val add_modtype : kernel_name -> module_type_body -> env -> env
+
+(* [shallow_add_module] does not add module components *)
+val shallow_add_module : module_path -> module_body -> env -> env
+
+val lookup_module : module_path -> env -> module_body
+val lookup_modtype : kernel_name -> env -> module_type_body
+
+(************************************************************************)
+(*s Universe constraints *)
+val set_universes   :   Univ.universes -> env -> env
+val add_constraints : Univ.constraints -> env -> env
+
+val set_engagement : engagement -> env -> env
+
+(************************************************************************)
+(* Sets of referred section variables *)
+(* [global_vars_set env c] returns the list of [id]'s occurring as
+   [VAR id] in [c] *)
+val global_vars_set : env -> constr -> Idset.t
+(* the constr must be an atomic construction *)
+val vars_of_global : env -> constr -> identifier list
+
+val keep_hyps : env -> Idset.t -> section_context
+
+(************************************************************************)
+(*s Unsafe judgments. We introduce here the pre-type of judgments, which is
+  actually only a datatype to store a term with its type and the type of its
+  type. *)
+
+type unsafe_judgment = { 
+  uj_val  : constr;
+  uj_type : types }
+
+val make_judge : constr -> types -> unsafe_judgment
+val j_val  : unsafe_judgment -> constr
+val j_type : unsafe_judgment -> types
+
+type unsafe_type_judgment = { 
+  utj_val  : constr;
+  utj_type : sorts }
+
+
+
+
+
+
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
new file mode 100644
index 00000000..38db01fc
--- /dev/null
+++ b/kernel/esubst.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  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: esubst.ml,v 1.4.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+(* Explicit lifts and basic operations *)
+type lift =
+  | ELID
+  | ELSHFT of lift * int (* ELSHFT(l,n) == lift of n, then apply lift l *)
+  | ELLFT of int * lift  (* ELLFT(n,l)  == apply l to de Bruijn > n *)
+                         (*                 i.e under n binders *)
+
+(* compose a relocation of magnitude n *)
+let rec el_shft_rec n = function
+  | ELSHFT(el,k) -> el_shft_rec (k+n) el
+  | el           -> ELSHFT(el,n)
+let el_shft n el = if n = 0 then el else el_shft_rec n el
+
+(* cross n binders *)
+let rec el_liftn_rec n = function
+  | ELID        -> ELID
+  | ELLFT(k,el) -> el_liftn_rec (n+k) el
+  | el          -> ELLFT(n, el)
+let el_liftn n el = if n = 0 then el else el_liftn_rec n el
+
+let el_lift el = el_liftn_rec 1 el
+
+(* relocation of de Bruijn n in an explicit lift *)
+let rec reloc_rel n = function
+  | ELID -> n
+  | ELLFT(k,el) ->
+      if n <= k then n else (reloc_rel (n-k) el) + k
+  | ELSHFT(el,k) -> (reloc_rel (n+k) el)
+
+let rec is_lift_id = function
+  | ELID -> true
+  | ELSHFT(e,n) -> n=0 & is_lift_id e
+  | ELLFT (_,e) -> is_lift_id e
+
+(*********************)
+(*  Substitutions    *)
+(*********************)
+
+(* (bounded) explicit substitutions of type 'a *)
+type 'a subs =
+  | ESID of int            (* ESID(n)    = %n END   bounded identity *)
+  | CONS of 'a * 'a subs   (* CONS(t,S)  = (S.t)    parallel substitution *)
+  | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *)
+                           (*                        with n vars *)
+  | LIFT of int * 'a subs  (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *)
+
+(* operations of subs: collapses constructors when possible.
+ * Needn't be recursive if we always use these functions
+ *)
+
+let subs_cons(x,s) = CONS(x,s)
+
+let subs_liftn n = function
+  | ESID p        -> ESID (p+n) (* bounded identity lifted extends by p *)
+  | LIFT (p,lenv) -> LIFT (p+n, lenv)
+  | lenv          -> LIFT (n,lenv)
+
+let subs_lift a = subs_liftn 1 a
+let subs_liftn n a = if n = 0 then a else subs_liftn n a
+
+let subs_shft = function
+  | (0, s)            -> s
+  | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1)
+  | (n, s)            -> SHIFT (n,s)
+let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a)
+
+let subs_shift_cons = function
+  (0, s, t)           -> CONS(t,s)
+| (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1))
+| (k, s, t)           -> CONS(t,SHIFT(k, s));;
+
+(* Tests whether a substitution is extensionnaly equal to the identity *)
+let rec is_subs_id = function
+    ESID _     -> true
+  | LIFT(_,s)  -> is_subs_id s
+  | SHIFT(0,s) -> is_subs_id s
+  | _          -> false
+
+(* Expands de Bruijn k in the explicit substitution subs
+ * lams accumulates de shifts to perform when retrieving the i-th value
+ * the rules used are the following:
+ *
+ *    [id]k       --> k
+ *    [S.t]1      --> t
+ *    [S.t]k      --> [S](k-1)  if k > 1
+ *    [^n o S] k  --> [^n]([S]k)
+ *    [(%n S)] k  --> k         if k <= n
+ *    [(%n S)] k  --> [^n]([S](k-n))
+ *
+ * the result is (Inr (k+lams,p)) when the variable is just relocated
+ * where p is None if the variable points inside subs and Some(k) if the
+ * variable points k bindings beyond subs.
+ *) 
+let rec exp_rel lams k subs =
+  match (k,subs) with
+    | (1, CONS (def,_))         -> Inl(lams,def)
+    | (_, CONS (_,l))           -> exp_rel lams (pred k) l
+    | (_, LIFT (n,_)) when k<=n -> Inr(lams+k,None)
+    | (_, LIFT (n,l))           -> exp_rel (n+lams) (k-n) l
+    | (_, SHIFT (n,s))          -> exp_rel (n+lams) k s
+    | (_, ESID n) when k<=n     -> Inr(lams+k,None)
+    | (_, ESID n)               -> Inr(lams+k,Some (k-n))
+
+let expand_rel k subs = exp_rel 0 k subs
+
+let rec comp mk_cl s1 s2 =
+  match (s1, s2) with
+    | _, ESID _ -> s1
+    | ESID _, _ -> s2
+    | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2)
+    | _, CONS(x,s') -> CONS(mk_cl(s1,x), comp mk_cl s1 s')
+    | CONS(x,s), SHIFT(k,s') -> comp mk_cl s (subs_shft(k-1, s'))
+    | CONS(x,s), LIFT(k,s') -> CONS(x,comp mk_cl s (subs_liftn (k-1) s'))
+    | LIFT(k,s), SHIFT(k',s') ->
+        if k<k'
+        then subs_shft(k, comp mk_cl s (subs_shft(k'-k, s')))
+        else subs_shft(k', comp mk_cl (subs_liftn (k-k') s) s')
+    | LIFT(k,s), LIFT(k',s') ->
+        if k<k'
+        then subs_liftn k (comp mk_cl s (subs_liftn (k'-k) s'))
+        else subs_liftn k' (comp mk_cl (subs_liftn (k-k') s) s')
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
new file mode 100644
index 00000000..b02d747b
--- /dev/null
+++ b/kernel/esubst.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        *)
+(************************************************************************)
+
+(* $Id: esubst.mli,v 1.3.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+(*s Compact representation of explicit relocations. \\
+   [ELSHFT(l,n)] == lift of [n], then apply [lift l].
+   [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
+type lift =
+  | ELID
+  | ELSHFT of lift * int
+  | ELLFT of int * lift
+
+val el_shft : int -> lift -> lift
+val el_liftn : int -> lift -> lift
+val el_lift : lift -> lift
+val reloc_rel : int -> lift -> int
+val is_lift_id : lift -> bool
+
+(*s Explicit substitutions of type ['a]. [ESID n] = %n~END = bounded identity. 
+  [CONS(t,S)] = $S.t$ i.e. parallel substitution. [SHIFT(n,S)] = 
+  $(\uparrow n~o~S)$ i.e. terms in S are relocated with n vars. 
+  [LIFT(n,S)] = $(\%n~S)$ stands for $((\uparrow n~o~S).n...1)$. *)
+type 'a subs =
+  | ESID of int
+  | CONS of 'a * 'a subs
+  | SHIFT of int * 'a subs
+  | LIFT of int * 'a subs
+
+val subs_cons: 'a * 'a subs -> 'a subs
+val subs_shft: int * 'a subs -> 'a subs
+val subs_lift: 'a subs -> 'a subs
+val subs_liftn: int -> 'a subs -> 'a subs
+val subs_shift_cons: int * 'a subs * 'a -> 'a subs
+val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
+val is_subs_id: 'a subs -> bool
+val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
\ No newline at end of file
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
new file mode 100644
index 00000000..88f837aa
--- /dev/null
+++ b/kernel/indtypes.ml
@@ -0,0 +1,548 @@
+(************************************************************************)
+(*  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: indtypes.ml,v 1.59.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Inductive
+open Sign
+open Environ
+open Reduction
+open Typeops
+open Entries
+
+(* [check_constructors_names id s cl] checks that all the constructors names
+   appearing in [l] are not present in the set [s], and returns the new set
+   of names. The name [id] is the name of the current inductive type, used
+   when reporting the error. *)
+
+(************************************************************************)
+(* Various well-formedness check for inductive declarations            *)
+
+type inductive_error =
+  (* These are errors related to inductive constructions in this module *)
+  | NonPos of env * constr * constr
+  | NotEnoughArgs of env * constr * constr
+  | NotConstructor of env * constr * constr
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier * identifier
+  | SameNamesOverlap of identifier list
+  | NotAnArity of identifier
+  | BadEntry
+  (* These are errors related to recursors building in Indrec *)
+  | NotAllowedCaseAnalysis of bool * sorts * inductive
+  | BadInduction of bool * identifier * sorts
+  | NotMutualInScheme
+
+exception InductiveError of inductive_error
+
+let check_constructors_names id =
+  let rec check idset = function
+    | [] -> idset
+    | c::cl -> 
+	if Idset.mem c idset then 
+	  raise (InductiveError (SameNamesConstructors (id,c)))
+	else
+	  check (Idset.add c idset) cl
+  in
+  check
+
+(* [mind_check_names mie] checks the names of an inductive types declaration,
+   and raises the corresponding exceptions when two types or two constructors
+   have the same name. *)
+
+let mind_check_names mie =
+  let rec check indset cstset = function
+    | [] -> ()
+    | ind::inds -> 
+	let id = ind.mind_entry_typename in
+	let cl = ind.mind_entry_consnames in
+	if Idset.mem id indset then
+	  raise (InductiveError (SameNamesTypes id))
+	else
+	  let cstset' = check_constructors_names id cstset cl in
+	  check (Idset.add id indset) cstset' inds
+  in
+  check Idset.empty Idset.empty mie.mind_entry_inds
+(* The above verification is not necessary from the kernel point of
+  vue since inductive and constructors are not referred to by their
+  name, but only by the name of the inductive packet and an index. *)
+
+let mind_check_arities env mie =
+  let check_arity id c =
+    if not (is_arity env c) then 
+      raise (InductiveError (NotAnArity id))
+  in
+  List.iter
+    (fun {mind_entry_typename=id; mind_entry_arity=ar} -> check_arity id ar)
+    mie.mind_entry_inds
+
+(************************************************************************)
+(************************************************************************)
+
+(* Typing the arities and constructor types *)
+
+let is_info_arity env c =
+  match dest_arity env c with
+    | (_,Prop Null) -> false 
+    | (_,Prop Pos)  -> true 
+    | (_,Type _)    -> true
+
+let is_info_type env t =
+  let s = t.utj_type in
+  if s = mk_Set then true
+  else if s = mk_Prop then false
+  else
+    try is_info_arity env t.utj_val
+    with UserError _ -> true
+
+(* [infos] is a sequence of pair [islogic,issmall] for each type in
+   the product of a constructor or arity *)
+
+let is_small infos = List.for_all (fun (logic,small) -> small) infos
+let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos
+let is_logic_arity infos =
+  List.for_all (fun (logic,small) -> logic || small) infos
+
+(* An inductive definition is a "unit" if it has only one constructor
+   and that all arguments expected by this constructor are 
+   logical, this is the case for equality, conjonction of logical properties 
+*)
+let is_unit constrsinfos =
+  match constrsinfos with  (* One info = One constructor *)
+   | [constrinfos] -> is_logic_constr constrinfos 
+   | [] -> (* type without constructors *) true
+   | _ -> false
+
+let rec infos_and_sort env t =
+  match kind_of_term t with
+    | Prod (name,c1,c2) ->
+        let (varj,_) = infer_type env c1 in
+	let env1 = Environ.push_rel (name,None,varj.utj_val) env in
+	let logic = not (is_info_type env varj) in
+	let small = Term.is_small varj.utj_type in
+	(logic,small) :: (infos_and_sort env1 c2)
+    | Cast (c,_) -> infos_and_sort env c
+    | _ -> []
+
+let small_unit constrsinfos =
+  let issmall = List.for_all is_small constrsinfos 
+  and isunit = is_unit constrsinfos in
+  issmall, isunit
+
+(* This (re)computes informations relevant to extraction and the sort of an
+   arity or type constructor; we do not to recompute universes constraints *)
+
+(* [smax] is the max of the sorts of the products of the constructor type *)
+
+let enforce_type_constructor env arsort smax cst =
+  match smax, arsort with
+    | Type uc, Type ua -> enforce_geq ua uc cst
+    | Type uc, Prop Pos when engagement env <> Some ImpredicativeSet ->
+        error "Large non-propositional inductive types must be in Type"
+    | _,_ -> cst
+
+let type_one_constructor env_ar_par params arsort c =
+  let infos = infos_and_sort env_ar_par c in
+
+  (* Each constructor is typed-checked here *)
+  let (j,cst) = infer_type env_ar_par c in
+  let full_cstr_type = it_mkProd_or_LetIn j.utj_val params in
+
+  (* If the arity is at some level Type arsort, then the sort of the
+     constructor must be below arsort; here we consider constructors with the
+     global parameters (which add a priori more constraints on their sort) *)
+  let cst2 = enforce_type_constructor env_ar_par arsort j.utj_type cst in
+
+  (infos, full_cstr_type, cst2)
+
+let infer_constructor_packet env_ar params arsort vc =
+  let env_ar_par = push_rel_context params env_ar in
+  let (constrsinfos,jlc,cst) = 
+    List.fold_right
+      (fun c (infosl,l,cst) ->
+	 let (infos,ct,cst') =
+	   type_one_constructor env_ar_par params arsort c in
+	 (infos::infosl,ct::l, Constraint.union cst cst'))
+      vc
+      ([],[],Constraint.empty) in
+  let vc' = Array.of_list jlc in
+  let issmall,isunit = small_unit constrsinfos in
+  (issmall,isunit,vc', cst)
+
+(* Type-check an inductive definition. Does not check positivity
+   conditions. *)
+let typecheck_inductive env mie =
+  if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration";
+  (* Check unicity of names *)
+  mind_check_names mie;
+  mind_check_arities env mie;
+  (* We first type params and arity of each inductive definition *)
+  (* This allows to build the environment of arities and to share *)
+  (* the set of constraints *)
+  let cst, arities, rev_params_arity_list =
+    List.fold_left
+      (fun (cst,arities,l) ind ->
+         (* Params are typed-checked here *)
+	 let params = ind.mind_entry_params in
+	 let env_params, params, cst1 =
+           infer_local_decls env params in
+         (* Arities (without params) are typed-checked here *)
+	 let arity, cst2 =
+           infer_type env_params ind.mind_entry_arity in
+	 (* We do not need to generate the universe of full_arity; if
+	    later, after the validation of the inductive definition,
+	    full_arity is used as argument or subject to cast, an
+	    upper universe will be generated *)
+	 let id = ind.mind_entry_typename in
+	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
+	 Constraint.union cst (Constraint.union cst1 cst2),
+	 Sign.add_rel_decl (Name id, None, full_arity) arities,
+         (params, id, full_arity, arity.utj_val)::l)
+      (Constraint.empty,empty_rel_context,[])
+      mie.mind_entry_inds in
+
+  let env_arities = push_rel_context arities env in
+
+  let params_arity_list = List.rev rev_params_arity_list in
+
+  (* Now, we type the constructors (without params) *)
+  let inds,cst =
+    List.fold_right2
+      (fun ind (params,id,full_arity,short_arity) (inds,cst) ->
+	 let (_,arsort) = dest_arity env full_arity in
+	 let lc = ind.mind_entry_lc in
+	 let (issmall,isunit,lc',cst') =
+	   infer_constructor_packet env_arities params arsort lc in
+	 let consnames = ind.mind_entry_consnames in
+	 let ind' = (params,id,full_arity,consnames,issmall,isunit,lc')
+	 in
+	 (ind'::inds, Constraint.union cst cst'))
+      mie.mind_entry_inds
+      params_arity_list
+      ([],cst) in
+  (env_arities, Array.of_list inds, cst)
+
+(************************************************************************)
+(************************************************************************)
+(* Positivity *)
+
+type ill_formed_ind =
+  | LocalNonPos of int
+  | LocalNotEnoughArgs of int
+  | LocalNotConstructor
+  | LocalNonPar of int * int
+
+exception IllFormedInd of ill_formed_ind
+
+(* [mind_extract_params mie] extracts the params from an inductive types
+   declaration, and checks that they are all present (and all the same)
+   for all the given types. *)
+
+let mind_extract_params = decompose_prod_n_assum
+
+let explain_ind_err ntyp env0 nbpar c err = 
+  let (lpar,c') = mind_extract_params nbpar c in
+  let env = push_rel_context lpar env0 in
+  match err with
+    | LocalNonPos kt -> 
+	raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar))))
+    | LocalNotEnoughArgs kt -> 
+	raise (InductiveError 
+		 (NotEnoughArgs (env,c',mkRel (kt+nbpar))))
+    | LocalNotConstructor ->
+	raise (InductiveError 
+		 (NotConstructor (env,c',mkRel (ntyp+nbpar))))
+    | LocalNonPar (n,l) ->
+	raise (InductiveError 
+		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
+
+let failwith_non_pos_vect n ntypes v =
+  for i = 0 to Array.length v - 1 do
+    for k = n to n + ntypes - 1 do
+      if not (noccurn k v.(i)) then raise (IllFormedInd (LocalNonPos (k-n+1)))
+    done
+  done;
+  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v"
+
+(* Check the inductive type is called with the expected parameters *)
+let check_correct_par (env,n,ntypes,_) hyps l largs =
+  let nparams = rel_context_nhyps hyps in
+  let largs = Array.of_list largs in
+  if Array.length largs < nparams then 
+    raise (IllFormedInd (LocalNotEnoughArgs l));
+  let (lpar,largs') = array_chop nparams largs in
+  let nhyps = List.length hyps in
+  let rec check k index = function
+    | [] -> ()
+    | (_,Some _,_)::hyps -> check k (index+1) hyps
+    | _::hyps ->
+        match kind_of_term (whd_betadeltaiota env lpar.(k)) with
+	  | Rel w when w = index -> check (k-1) (index+1) hyps
+	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
+  in check (nparams-1) (n-nhyps) hyps;
+  if not (array_for_all (noccur_between n ntypes) largs') then 
+    failwith_non_pos_vect n ntypes largs'
+
+(* This removes global parameters of the inductive types in lc (for
+   nested inductive types only ) *)
+let abstract_mind_lc env ntyps npars lc = 
+  if npars = 0 then 
+    lc
+  else 
+    let make_abs = 
+      list_tabulate
+	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps 
+    in 
+    Array.map (substl make_abs) lc
+
+(* [env] is the typing environment
+   [n] is the dB of the last inductive type
+   [ntypes] is the number of inductive types in the definition
+     (i.e. range of inductives is [n; n+ntypes-1])
+   [lra] is the list of recursive tree of each variable
+ *) 
+let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
+ (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+
+let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
+  let auxntyp = 1 in
+  let env' =
+    push_rel (Anonymous,None,
+              hnf_prod_applist env (type_of_inductive env mi) lpar) env in
+  let ra_env' = 
+    (Imbr mi,Rtree.mk_param 0) ::
+    List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
+  (* New index of the inductive types *)
+  let newidx = n + auxntyp in
+  (env', newidx, ntypes, ra_env')
+
+(* The recursive function that checks positivity and builds the list
+   of recursive arguments *)
+let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
+  let nparams = rel_context_length hyps in
+  (* check the inductive types occur positively in [c] *)
+  let rec check_pos (env, n, ntypes, ra_env as ienv) c = 
+    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    match kind_of_term x with
+      | Prod (na,b,d) ->
+	  assert (largs = []);
+          if not (noccur_between n ntypes b) then
+	    raise (IllFormedInd (LocalNonPos n));
+	  check_pos (ienv_push_var ienv (na, b, mk_norec)) d
+      | Rel k ->
+          let (ra,rarg) =
+            try List.nth ra_env (k-1)
+            with Failure _ | Invalid_argument _ -> (Norec,mk_norec) in
+          (match ra with
+              Mrec _ -> check_correct_par ienv hyps (k-n+1) largs
+            | _ ->
+                if not (List.for_all (noccur_between n ntypes) largs)
+	        then raise (IllFormedInd (LocalNonPos n)));
+          rarg
+      | Ind ind_kn ->
+          (* If the inductive type being defined appears in a
+             parameter, then we have an imbricated type *)
+          if List.for_all (noccur_between n ntypes) largs then mk_norec
+          else check_positive_imbr ienv (ind_kn, largs)
+      | err -> 
+	  if noccur_between n ntypes x &&
+             List.for_all (noccur_between n ntypes) largs 
+	  then mk_norec
+	  else raise (IllFormedInd (LocalNonPos n))
+
+  (* accesses to the environment are not factorised, but does it worth
+     it? *)
+  and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) =
+    let (mib,mip) = lookup_mind_specif env mi in
+    let auxnpar = mip.mind_nparams in
+    let (lpar,auxlargs) =
+      try list_chop auxnpar largs 
+      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
+    (* If the inductive appears in the args (non params) then the
+       definition is not positive. *)
+    if not (List.for_all (noccur_between n ntypes) auxlargs) then
+      raise (IllFormedInd (LocalNonPos n));
+    (* We do not deal with imbricated mutual inductive types *)
+    let auxntyp = mib.mind_ntypes in 
+    if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+    (* The nested inductive type with parameters removed *)
+    let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+    (* Extends the environment with a variable corresponding to
+       the inductive def *)
+    let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
+    (* Parameters expressed in env' *)
+    let lpar' = List.map (lift auxntyp) lpar in
+    let irecargs = 
+      (* fails if the inductive type occurs non positively *)
+      (* when substituted *) 
+      Array.map 
+	(function c -> 
+	  let c' = hnf_prod_applist env' c lpar' in 
+	  check_constructors ienv' false c') 
+	auxlcvect
+    in 
+    (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)
+  
+  (* check the inductive types occur positively in the products of C, if
+     check_head=true, also check the head corresponds to a constructor of
+     the ith type *) 
+
+  and check_constructors ienv check_head c = 
+    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = 
+      let x,largs = decompose_app (whd_betadeltaiota env c) in
+      match kind_of_term x with
+
+        | Prod (na,b,d) -> 
+	    assert (largs = []);
+            let recarg = check_pos ienv b in 
+            let ienv' = ienv_push_var ienv (na,b,mk_norec) in
+	    check_constr_rec ienv' (recarg::lrec) d
+
+	| hd ->
+	    if check_head then
+	      if hd = Rel (n+ntypes-i-1) then
+		check_correct_par ienv hyps (ntypes-i) largs
+	      else
+		raise (IllFormedInd LocalNotConstructor)
+	    else
+	      if not (List.for_all (noccur_between n ntypes) largs)
+              then raise (IllFormedInd (LocalNonPos n));
+	    List.rev lrec
+    in check_constr_rec ienv [] c
+  in
+  mk_paths (Mrec i)
+    (Array.map
+      (fun c ->
+        let c = body_of_type c in
+        let sign, rawc = mind_extract_params nparams c in
+        let env' = push_rel_context sign env in
+        try
+	  check_constructors ienv true rawc
+        with IllFormedInd err -> 
+	  explain_ind_err (ntypes-i) env nparams c err)
+      indlc)
+
+let check_positivity env_ar inds =
+  let ntypes = Array.length inds in
+  let lra_ind =
+    List.rev (list_tabulate (fun j -> (Mrec j, Rtree.mk_param j)) ntypes) in
+  let check_one i (params,_,_,_,_,_,lc) =
+    let nparams = rel_context_length params in
+    let ra_env =
+      list_tabulate (fun _ -> (Norec,mk_norec)) nparams @ lra_ind in
+    let ienv = (env_ar, 1+nparams, ntypes, ra_env) in
+    check_positivity_one ienv params i lc in
+  Rtree.mk_rec (Array.mapi check_one inds)
+
+
+(************************************************************************)
+(************************************************************************)
+(* Build the inductive packet *)
+    
+(* Elimination sorts *)
+let is_recursive = Rtree.is_infinite
+(*  let rec one_is_rec rvec = 
+    List.exists (function Mrec(i) -> List.mem i listind 
+                   | Imbr(_,lvec) -> array_exists one_is_rec lvec
+                   | Norec -> false) rvec
+  in 
+  array_exists one_is_rec
+*)
+
+let all_sorts = [InProp;InSet;InType]
+let impredicative_sorts = [InProp;InSet]
+let logical_sorts = [InProp]
+
+let allowed_sorts env issmall isunit = function
+  | Type _ -> all_sorts
+  | Prop Pos -> 
+      if issmall then all_sorts
+      else impredicative_sorts
+  | Prop Null -> 
+(* Added InType which is derivable :when the type is unit and small *)
+(* unit+small types have all elimination 
+   In predicative system, the 
+   other inductive definitions have only Prop elimination.
+   In impredicative system, large unit type have also Set elimination
+*)   if isunit then 
+	if issmall then all_sorts
+	else if Environ.engagement env = None 
+        then logical_sorts else impredicative_sorts
+      else logical_sorts
+
+let build_inductive env env_ar finite inds recargs cst =
+  let ntypes = Array.length inds in
+  (* Compute the set of used section variables *)
+  let ids = 
+    Array.fold_left 
+      (fun acc (_,_,ar,_,_,_,lc) -> 
+	 Idset.union (Environ.global_vars_set env (body_of_type ar))
+	   (Array.fold_left
+	      (fun acc c ->
+                Idset.union (global_vars_set env (body_of_type c)) acc)
+	      acc
+	      lc))
+      Idset.empty inds in
+  let hyps = keep_hyps env ids in
+  (* Check one inductive *)
+  let build_one_packet (params,id,ar,cnames,issmall,isunit,lc) recarg =
+    (* Arity in normal form *)
+    let nparamargs = rel_context_nhyps params in
+    let (ar_sign,ar_sort) = dest_arity env ar in
+    let nf_ar =
+      if isArity (body_of_type ar) then ar
+      else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in
+    (* Type of constructors in normal form *)
+    let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
+    let nf_lc =
+      array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in
+    let nf_lc = if nf_lc = lc then lc else nf_lc in
+    (* Elimination sorts *)
+    let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in
+    let kelim = allowed_sorts env issmall isunit ar_sort in
+    (* Build the inductive packet *)
+    { mind_typename = id;
+      mind_nparams = nparamargs;
+      mind_params_ctxt = params;
+      mind_user_arity  = ar;
+      mind_nf_arity = nf_ar;
+      mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
+      mind_sort = ar_sort;
+      mind_kelim = kelim;
+      mind_consnames = Array.of_list cnames;
+      mind_user_lc = lc;
+      mind_nf_lc = nf_lc;
+      mind_recargs = recarg;
+    } in
+  let packets = array_map2 build_one_packet inds recargs in
+  (* Build the mutual inductive *)
+  { mind_ntypes = ntypes;
+    mind_finite = finite;
+    mind_hyps = hyps;
+    mind_packets = packets;
+    mind_constraints = cst;
+    mind_equiv = None;
+  }
+
+(************************************************************************)
+(************************************************************************)
+
+let check_inductive env mie =
+  (* First type-check the inductive definition *)
+  let (env_arities, inds, cst) = typecheck_inductive env mie in
+  (* Then check positivity conditions *)
+  let recargs = check_positivity env_arities inds in
+  (* Build the inductive packets *)
+  build_inductive env env_arities mie.mind_entry_finite inds recargs cst
+
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
new file mode 100644
index 00000000..f5e6d047
--- /dev/null
+++ b/kernel/indtypes.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: indtypes.mli,v 1.23.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Entries
+open Typeops
+(*i*)
+
+
+(*s The different kinds of errors that may result of a malformed inductive
+  definition. *)
+
+type inductive_error =
+  (* These are errors related to inductive constructions in this module *)
+  | NonPos of env * constr * constr
+  | NotEnoughArgs of env * constr * constr
+  | NotConstructor of env * constr * constr
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier * identifier
+  | SameNamesOverlap of identifier list
+  | NotAnArity of identifier
+  | BadEntry
+  (* These are errors related to recursors building in Indrec *)
+  | NotAllowedCaseAnalysis of bool * sorts * inductive
+  | BadInduction of bool * identifier * sorts
+  | NotMutualInScheme
+
+exception InductiveError of inductive_error
+
+(*s The following function does checks on inductive declarations. *)
+
+val check_inductive :
+  env -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
new file mode 100644
index 00000000..07e9b8ea
--- /dev/null
+++ b/kernel/inductive.ml
@@ -0,0 +1,831 @@
+(************************************************************************)
+(*  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: inductive.ml,v 1.74.2.2 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Sign
+open Declarations
+open Environ
+open Reduction
+open Type_errors
+
+(* raise Not_found if not an inductive type *)
+let lookup_mind_specif env (kn,tyi) =
+  let mib = Environ.lookup_mind kn env in
+  if tyi >= Array.length mib.mind_packets then
+    error "Inductive.lookup_mind_specif: invalid inductive index";
+  (mib, mib.mind_packets.(tyi))
+
+let find_rectype env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match kind_of_term t with
+    | Ind ind -> (ind, l)
+    | _ -> raise Not_found
+
+let find_inductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match kind_of_term t with
+    | Ind ind
+        when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+let find_coinductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match kind_of_term t with
+    | Ind ind
+        when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+(************************************************************************)
+
+(* Build the substitution that replaces Rels by the appropriate *)
+(* inductives *)
+let ind_subst mind mib =
+  let ntypes = mib.mind_ntypes in
+  let make_Ik k = mkInd (mind,ntypes-k-1) in 
+  list_tabulate make_Ik ntypes
+
+(* Instantiate inductives in constructor type *)
+let constructor_instantiate mind mib c =
+  let s = ind_subst mind mib in
+  type_app (substl s) c
+
+(* Instantiate the parameters of the inductive type *)
+(* TODO: verify the arg of LetIn correspond to the value in the
+   signature ? *)
+let instantiate_params t args sign =
+  let fail () =
+    anomaly "instantiate_params: type, ctxt and args mismatch" in
+  let (rem_args, subs, ty) =
+    Sign.fold_rel_context
+      (fun (_,copt,_) (largs,subs,ty) ->
+        match (copt, largs, kind_of_term ty) with
+          | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
+          | (Some b,_,LetIn(_,_,_,t))    -> (largs, (substl subs b)::subs, t)
+	  | _                            -> fail())
+      sign
+      ~init:(args,[],t) 
+  in
+  if rem_args <> [] then fail();
+  type_app (substl subs) ty
+
+let full_inductive_instantiate mip params t =
+  instantiate_params t params mip.mind_params_ctxt
+
+let full_constructor_instantiate (((mind,_),mib,mip),params) =
+  let inst_ind = constructor_instantiate mind mib in
+  (fun t ->
+    instantiate_params (inst_ind t) params mip.mind_params_ctxt)
+
+(************************************************************************)
+(************************************************************************)
+
+(* Functions to build standard types related to inductive *)
+
+(* Type of an inductive type *)
+
+let type_of_inductive env i =
+  let (_,mip) = lookup_mind_specif env i in
+  mip.mind_user_arity
+
+(************************************************************************)
+(* Type of a constructor *)
+
+let type_of_constructor env cstr =
+  let ind = inductive_of_constructor cstr in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let specif = mip.mind_user_lc in
+  let i = index_of_constructor cstr in
+  let nconstr = Array.length mip.mind_consnames in
+  if i > nconstr then error "Not enough constructors in the type";
+  constructor_instantiate (fst ind) mib specif.(i-1)
+
+let arities_of_specif kn (mib,mip) = 
+  let specif = mip.mind_nf_lc in
+  Array.map (constructor_instantiate kn mib) specif
+
+let arities_of_constructors env ind = 
+  arities_of_specif (fst ind) (lookup_mind_specif env ind)
+
+
+
+(************************************************************************)
+
+let is_info_arity env c =
+  match dest_arity env c with
+    | (_,Prop Null) -> false 
+    | (_,Prop Pos)  -> true 
+    | (_,Type _)    -> true
+
+let error_elim_expln env kp ki =
+  if is_info_arity env kp && not (is_info_arity env ki) then
+    NonInformativeToInformative
+  else 
+    match (kind_of_term kp,kind_of_term ki) with 
+      | Sort (Type _), Sort (Prop _) -> StrongEliminationOnNonSmallType
+      | _ -> WrongArity
+
+(* Type of case predicates *)
+
+let local_rels ctxt =
+  let (rels,_) =
+    Sign.fold_rel_context_reverse
+      (fun (rels,n) (_,copt,_) ->
+        match copt with
+            None   -> (mkRel n :: rels, n+1)
+          | Some _ -> (rels, n+1))
+      ~init:([],1)
+      ctxt 
+  in
+  rels
+
+(* Get type of inductive, with parameters instantiated *)
+let get_arity mip params =
+  let arity = mip.mind_nf_arity in
+  destArity (full_inductive_instantiate mip params arity)
+
+let build_dependent_inductive ind mip params =
+  let arsign,_ = get_arity mip params in
+  let nrealargs = mip.mind_nrealargs in
+  applist 
+    (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign))
+
+
+(* This exception is local *)
+exception LocalArity of (constr * constr * arity_error) option
+
+let is_correct_arity env c pj ind mip params = 
+  let kelim = mip.mind_kelim in
+  let arsign,s = get_arity mip params in
+  let nodep_ar = it_mkProd_or_LetIn (mkSort s) arsign in
+  let rec srec env pt t u =
+    let pt' = whd_betadeltaiota env pt in
+    let t' = whd_betadeltaiota env t in
+    match kind_of_term pt', kind_of_term t' with
+      | Prod (na1,a1,a2), Prod (_,a1',a2') ->
+          let univ =
+            try conv env a1 a1'
+            with NotConvertible -> raise (LocalArity None) in
+          srec (push_rel (na1,None,a1) env) a2 a2' (Constraint.union u univ)
+      | Prod (_,a1,a2), _ -> 
+          let k = whd_betadeltaiota env a2 in 
+          let ksort = match kind_of_term k with
+            | Sort s -> family_of_sort s 
+	    | _ -> raise (LocalArity None) in
+	  let dep_ind = build_dependent_inductive ind mip params in
+          let univ =
+            try conv env a1 dep_ind
+            with NotConvertible -> raise (LocalArity None) in
+          if List.exists ((=) ksort) kelim then
+	    (true, Constraint.union u univ)
+          else 
+	    raise (LocalArity (Some(k,t',error_elim_expln env k t')))
+      | k, Prod (_,_,_) ->
+	  raise (LocalArity None)
+      | k, ki -> 
+	  let ksort = match k with
+            | Sort s -> family_of_sort s 
+            | _ ->  raise (LocalArity None) in
+          if List.exists ((=) ksort) kelim then 
+	    (false, u)
+          else 
+	    raise (LocalArity (Some(pt',t',error_elim_expln env pt' t')))
+  in 
+  try srec env pj.uj_type nodep_ar Constraint.empty
+  with LocalArity kinds ->
+    let create_sort = function 
+      | InProp -> mkProp
+      | InSet -> mkSet
+      | InType -> mkSort type_0 in
+    let listarity = List.map create_sort kelim
+(*    let listarity =
+      (List.map (fun s -> make_arity env true indf (create_sort s)) kelim)
+      @(List.map (fun s -> make_arity env false indf (create_sort s)) kelim)*)
+    in 
+    error_elim_arity env ind listarity c pj kinds
+
+
+(************************************************************************)
+(* Type of case branches *)
+
+(* [p] is the predicate, [i] is the constructor number (starting from 0),
+   and [cty] is the type of the constructor (params not instantiated) *)
+let build_branches_type ind mib mip params dep p =
+  let build_one_branch i cty =
+    let typi = full_constructor_instantiate ((ind,mib,mip),params) cty in
+    let (args,ccl) = decompose_prod_assum typi in
+    let nargs = rel_context_length args in
+    let (_,allargs) = decompose_app ccl in
+    let (lparams,vargs) = list_chop mip.mind_nparams allargs in
+    let cargs =
+      if dep then
+        let cstr = ith_constructor_of_inductive ind (i+1) in
+        let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
+        vargs @ [dep_cstr]
+      else
+        vargs in
+    let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
+    it_mkProd_or_LetIn base args in
+  Array.mapi build_one_branch mip.mind_nf_lc
+
+(* [p] is the predicate, [c] is the match object, [realargs] is the
+   list of real args of the inductive type *)
+let build_case_type dep p c realargs =
+  let args = if dep then realargs@[c] else realargs in
+  beta_appvect p (Array.of_list args)
+
+let type_case_branches env (ind,largs) pj c =
+  let (mib,mip) = lookup_mind_specif env ind in 
+  let nparams = mip.mind_nparams in
+  let (params,realargs) = list_chop nparams largs in
+  let p = pj.uj_val in
+  let (dep,univ) = is_correct_arity env c pj ind mip params in
+  let lc = build_branches_type ind mib mip params dep p in
+  let ty = build_case_type dep p c realargs in
+  (lc, ty, univ)
+
+
+(************************************************************************)
+(* Checking the case annotation is relevent *)
+
+let check_case_info env indsp ci =
+  let (mib,mip) = lookup_mind_specif env indsp in
+  if
+    (indsp <> ci.ci_ind) or
+    (mip.mind_nparams <> ci.ci_npar)
+  then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
+
+(************************************************************************)
+(************************************************************************)
+
+(* Guard conditions for fix and cofix-points *)
+
+(* Check if t is a subterm of Rel n, and gives its specification, 
+   assuming lst already gives index of
+   subterms with corresponding specifications of recursive arguments *)
+
+(* A powerful notion of subterm *)
+
+(* To each inductive definition corresponds an array describing the
+   structure of recursive arguments for each constructor, we call it
+   the recursive spec of the type (it has type recargs vect).  For
+   checking the guard, we start from the decreasing argument (Rel n)
+   with its recursive spec.  During checking the guardness condition,
+   we collect patterns variables corresponding to subterms of n, each
+   of them with its recursive spec.  They are organised in a list lst
+   of type (int * recargs) list which is sorted with respect to the
+   first argument.
+*)
+
+(*************************)
+(* Environment annotated with marks on recursive arguments:
+   it is a triple (env,lst,n) where
+   - env is the typing environment
+   - lst is a mapping from de Bruijn indices to list of recargs
+     (tells which subterms of that variable are recursive)
+   - n is the de Bruijn index of the fixpoint for which we are
+     checking the guard condition.
+
+   Below are functions to handle such environment.
+ *)
+type size = Large | Strict
+
+let size_glb s1 s2 =
+  match s1,s2 with
+      Strict, Strict -> Strict
+    | _ -> Large
+
+type subterm_spec =
+    Subterm of (size * wf_paths)
+  | Dead_code
+  | Not_subterm
+
+let spec_of_tree t =
+  if t=mk_norec then Not_subterm else Subterm(Strict,t)
+
+let subterm_spec_glb =
+  let glb2 s1 s2 =
+    match s1,s2 with
+        _, Dead_code -> s1
+      | Dead_code, _ -> s2
+      | Not_subterm, _ -> Not_subterm
+      | _, Not_subterm -> Not_subterm
+      | Subterm (a1,t1), Subterm (a2,t2) ->
+          if t1=t2 then Subterm (size_glb a1 a2, t1)
+          (* branches do not return objects with same spec *)
+          else Not_subterm in
+  Array.fold_left glb2 Dead_code
+          
+type guard_env =
+  { env     : env;
+    (* dB of last fixpoint *)
+    rel_min : int;
+    (* inductive of recarg of each fixpoint *)
+    inds    : inductive array;
+    (* the recarg information of inductive family *)
+    recvec  : wf_paths array;
+    (* dB of variables denoting subterms *)
+    genv    : subterm_spec list;
+  }
+
+let make_renv env minds recarg (kn,tyi) =
+  let mib = Environ.lookup_mind kn env in
+  let mind_recvec =
+    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+  { env = env;
+    rel_min = recarg+2;
+    inds = minds;
+    recvec = mind_recvec;
+    genv = [Subterm(Large,mind_recvec.(tyi))] }
+
+let push_var renv (x,ty,spec) =
+  { renv with 
+    env = push_rel (x,None,ty) renv.env;
+    rel_min = renv.rel_min+1;
+    genv = spec:: renv.genv }
+
+let assign_var_spec renv (i,spec) =
+  { renv with genv = list_assign renv.genv (i-1) spec }
+
+let push_var_renv renv (x,ty) =
+  push_var renv (x,ty,Not_subterm)
+
+(* Fetch recursive information about a variable p *)
+let subterm_var p renv = 
+  try List.nth renv.genv (p-1)
+  with Failure _ | Invalid_argument _ -> Not_subterm
+
+(* Add a variable and mark it as strictly smaller with information [spec]. *)
+let add_subterm renv (x,a,spec) =
+  push_var renv (x,a,spec_of_tree spec)
+
+let push_ctxt_renv renv ctxt =
+  let n = rel_context_length ctxt in
+  { renv with 
+    env = push_rel_context ctxt renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+let push_fix_renv renv (_,v,_ as recdef) =
+  let n = Array.length v in
+  { renv with
+    env = push_rec_types recdef renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+
+(******************************)
+(* Computing the recursive subterms of a term (propagation of size
+   information through Cases). *)
+
+(*
+   c is a branch of an inductive definition corresponding to the spec
+   lrec.  mind_recvec is the recursive spec of the inductive
+   definition of the decreasing argument n.
+
+   case_branches_specif renv lrec lc will pass the lambdas
+   of c corresponding to pattern variables and collect possibly new
+   subterms variables and returns the bodies of the branches with the
+   correct envs and decreasing args.
+*)
+
+let lookup_subterms env ind =
+  let (_,mip) = lookup_mind_specif env ind in
+  mip.mind_recargs
+
+(*********************************)
+
+(* finds the inductive type of the recursive argument of a fixpoint *)
+let inductive_of_fix env recarg body =
+  let (ctxt,b) = decompose_lam_n_assum recarg body in
+  let env' = push_rel_context ctxt env in
+  let (_,ty,_) = destLambda(whd_betadeltaiota env' b) in
+  let (i,_) = decompose_app (whd_betadeltaiota env' ty) in 
+  destInd i
+
+(* 
+   subterm_specif env c ind 
+
+   subterm_specif should test if [c] (building objects of inductive
+   type [ind], not necassarily the same as that of the recursive
+   argument) is a subterm of the recursive argument of the fixpoint we
+   are checking and fails with Not_found if not. In case it is, it
+   should send its recursive specification (i.e. on which arguments we
+   are allowed to make recursive calls). This recursive spec should be
+   the same size as the number of constructors of the type of c.
+
+   Returns:
+   - [Some lc] if [c] is a strict subterm of the rec. arg. (or a Meta) 
+   - [None] otherwise
+*)
+
+let rec subterm_specif renv t ind = 
+  let f,l = decompose_app (whd_betadeltaiota renv.env t) in
+  match kind_of_term f with 
+    | Rel k -> subterm_var k renv
+
+    | Case (ci,_,c,lbr) ->
+        if Array.length lbr = 0 then Dead_code
+        else
+          let lbr_spec = case_branches_specif renv c ci.ci_ind lbr in
+          let stl  =
+            Array.map (fun (renv',br') -> subterm_specif renv' br' ind)
+              lbr_spec in
+          subterm_spec_glb stl
+	       
+    | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+(* when proving that the fixpoint f(x)=e is less than n, it is enough
+   to prove that e is less than n assuming f is less than n
+   furthermore when f is applied to a term which is strictly less than
+   n, one may assume that x itself is strictly less than n
+*)
+        let nbfix = Array.length typarray in
+        let recargs = lookup_subterms renv.env ind in
+        (* pushing the fixpoints *)
+        let renv' = push_fix_renv renv recdef in
+        let renv' =
+          assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
+        let decrArg = recindxs.(i) in 
+        let theBody = bodies.(i)   in
+        let nbOfAbst = decrArg+1 in
+        let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+        (* pushing the fix parameters *)
+        let renv'' = push_ctxt_renv renv' sign in
+        let renv'' =
+          if List.length l < nbOfAbst then renv''
+          else
+            let decrarg_ind = inductive_of_fix renv''.env decrArg theBody in
+            let theDecrArg  = List.nth l decrArg in
+	    let arg_spec    = subterm_specif renv theDecrArg decrarg_ind in
+            assign_var_spec renv'' (1, arg_spec) in
+	subterm_specif renv'' strippedBody ind
+	    
+    | Lambda (x,a,b) -> 
+        assert (l=[]);
+        subterm_specif (push_var_renv renv (x,a)) b ind
+
+    (* A term with metas is considered OK *)
+    | Meta _ -> Dead_code
+    (* Other terms are not subterms *)
+    | _ -> Not_subterm
+
+(* Propagation of size information through Cases: if the matched
+   object is a recursive subterm then compute the information
+   associated to its own subterms.
+   Rq: if branch is not eta-long, then the recursive information
+   is not propagated *)
+and case_branches_specif renv c ind lbr = 
+  let c_spec = subterm_specif renv c ind in
+  let rec push_branch_args renv lrec c = 
+    let c' = strip_outer_cast (whd_betadeltaiota renv.env c) in 
+    match lrec, kind_of_term c' with 
+      |	(ra::lr,Lambda (x,a,b)) ->
+          let renv' = push_var renv (x,a,ra) in
+          push_branch_args renv' lr b
+      | (_,_) -> (renv,c') in
+  match c_spec with
+      Subterm (_,t) ->
+        let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Dead_code -> 
+        let t = dest_subterms (lookup_subterms renv.env ind) in
+        let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
+
+(* Check term c can be applied to one of the mutual fixpoints. *)
+let check_is_subterm renv c ind = 
+  match subterm_specif renv c ind with
+    Subterm (Strict,_) | Dead_code -> true
+  |  _ -> false
+
+(************************************************************************)
+
+exception FixGuardError of env * guard_error
+
+let error_illegal_rec_call renv fx arg =
+  let (_,le_vars,lt_vars) =
+    List.fold_left
+      (fun (i,le,lt) sbt ->
+        match sbt with
+            (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt)
+          | (Subterm(Large,_)) -> (i+1, i::le, lt)
+          | _ -> (i+1, le ,lt))
+      (1,[],[]) renv.genv in
+  raise (FixGuardError (renv.env,
+                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+
+let error_partial_apply renv fx =
+  raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
+
+
+(* Check if [def] is a guarded fixpoint body with decreasing arg.
+   given [recpos], the decreasing arguments of each mutually defined
+   fixpoint. *)
+let check_one_fix renv recpos def =
+  let nfi = Array.length recpos in 
+  let rec check_rec_call renv t = 
+    (* if [t] does not make recursive calls, it is guarded: *)
+    noccur_with_meta renv.rel_min nfi t or 
+    (* Rq: why not try and expand some definitions ? *)
+    let f,l = decompose_app (whd_betaiotazeta renv.env t) in
+    match kind_of_term f with
+      | Rel p -> 
+          (* Test if it is a recursive call: *) 
+	  if renv.rel_min <= p & p < renv.rel_min+nfi then
+            (* the position of the invoked fixpoint: *) 
+	    let glob = renv.rel_min+nfi-1-p in
+            (* the decreasing arg of the rec call: *)
+	    let np = recpos.(glob) in
+            if List.length l <= np then error_partial_apply renv glob;
+	    match list_chop np l with
+		(la,(z::lrest)) -> 
+                  (* Check the decreasing arg is smaller *)
+	          if not (check_is_subterm renv z renv.inds.(glob)) then
+                    error_illegal_rec_call renv glob z;
+                  List.for_all (check_rec_call renv) (la@lrest)
+		| _ -> assert false
+          (* otherwise check the arguments are guarded: *)
+	  else List.for_all (check_rec_call renv) l        
+
+      | Case (ci,p,c_0,lrest) ->
+          List.for_all (check_rec_call renv) (c_0::p::l) &&
+          (* compute the recarg information for the arguments of
+             each branch *)
+          let lbr = case_branches_specif renv c_0 ci.ci_ind lrest in
+          array_for_all (fun (renv',br') -> check_rec_call renv' br') lbr
+
+  (* Enables to traverse Fixpoint definitions in a more intelligent
+     way, ie, the rule :
+
+     if - g = Fix g/1 := [y1:T1]...[yp:Tp]e &
+        - f is guarded with respect to the set of pattern variables S 
+          in a1 ... am        &
+        - f is guarded with respect to the set of pattern variables S 
+          in T1 ... Tp        &
+        - ap is a sub-term of the formal argument of f &
+        - f is guarded with respect to the set of pattern variables S+{yp}
+          in e
+     then f is guarded with respect to S in (g a1 ... am).
+
+     Eduardo 7/9/98 *)
+
+      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+          List.for_all (check_rec_call renv) l &&
+          array_for_all (check_rec_call renv) typarray && 
+	  let nbfix = Array.length typarray in
+          let decrArg = recindxs.(i) in
+          let renv' = push_fix_renv renv recdef in 
+          if (List.length l < (decrArg+1)) then
+	    array_for_all (check_rec_call renv') bodies
+          else 
+            let ok_vect =
+              Array.mapi
+                (fun j body ->
+                  if i=j then
+                    let decrarg_ind =
+                      inductive_of_fix renv'.env decrArg body in
+                    let theDecrArg  = List.nth l decrArg in
+	            let arg_spec =
+                      subterm_specif renv theDecrArg decrarg_ind in
+	            check_nested_fix_body renv' (decrArg+1) arg_spec body
+                  else check_rec_call renv' body)
+                bodies in
+            array_for_all (fun b -> b) ok_vect
+
+      | Const kn as c -> 
+          (try List.for_all (check_rec_call renv) l
+           with (FixGuardError _ ) as e ->
+             if evaluable_constant kn renv.env then 
+	       check_rec_call renv
+                 (applist(constant_value renv.env kn, l))
+	     else raise e)
+
+      (* The cases below simply check recursively the condition on the
+         subterms *)
+      | Cast (a,b) -> 
+          List.for_all (check_rec_call renv) (a::b::l)
+
+      | Lambda (x,a,b) ->
+          check_rec_call (push_var_renv renv (x,a)) b &&
+          List.for_all (check_rec_call renv) (a::l)
+
+      | Prod (x,a,b) -> 
+          check_rec_call (push_var_renv renv (x,a)) b &&
+          List.for_all (check_rec_call renv) (a::l)
+
+      | CoFix (i,(_,typarray,bodies as recdef)) ->
+	  array_for_all (check_rec_call renv) typarray &&
+          List.for_all (check_rec_call renv) l &&
+	  let renv' = push_fix_renv renv recdef in
+	  array_for_all (check_rec_call renv') bodies
+
+      | Evar (_,la) -> 
+	  array_for_all (check_rec_call renv) la &&
+          List.for_all (check_rec_call renv) l
+
+      | Meta _ -> true
+
+      | (App _ | LetIn _) -> 
+	  anomaly "check_rec_call: should have been reduced"
+
+      | (Ind _ | Construct _ | Var _ | Sort _) ->
+          List.for_all (check_rec_call renv) l
+
+  and check_nested_fix_body renv decr recArgsDecrArg body =
+    if decr = 0 then
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+    else
+      match kind_of_term body with
+	| Lambda (x,a,b) ->
+            let renv' = push_var_renv renv (x,a) in
+	    check_rec_call renv a &&
+	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+	| _ -> anomaly "Not enough abstractions in fix body"
+    
+  in
+  check_rec_call renv def
+
+
+let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
+  let nbfix = Array.length bodies in 
+  if nbfix = 0
+    or Array.length nvect <> nbfix 
+    or Array.length types <> nbfix
+    or Array.length names <> nbfix
+    or bodynum < 0
+    or bodynum >= nbfix
+  then anomaly "Ill-formed fix term";
+  let fixenv = push_rec_types recdef env in
+  let raise_err i err =
+    error_ill_formed_rec_body fixenv err names i in
+  (* Check the i-th definition with recarg k *)
+  let find_ind i k def = 
+    if k < 0 then anomaly "negative recarg position";
+    (* check fi does not appear in the k+1 first abstractions, 
+       gives the type of the k+1-eme abstraction (must be an inductive)  *)
+    let rec check_occur env n def = 
+      match kind_of_term (whd_betadeltaiota env def) with
+        | Lambda (x,a,b) -> 
+	    if noccur_with_meta n nbfix a then
+	      let env' = push_rel (x, None, a) env in
+              if n = k+1 then
+                (* get the inductive type of the fixpoint *)
+                let (mind, _) = 
+                  try find_inductive env a 
+                  with Not_found -> raise_err i RecursionNotOnInductiveType in
+                (mind, (env', b))
+	      else check_occur env' (n+1) b
+            else anomaly "check_one_fix: Bad occurrence of recursive call"
+        | _ -> raise_err i NotEnoughAbstractionInFixBody in
+    check_occur fixenv 1 def in
+  (* Do it on every fixpoint *)
+  let rv = array_map2_i find_ind nvect bodies in
+  (Array.map fst rv, Array.map snd rv)
+
+
+let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
+  let (minds, rdef) = inductive_of_mutfix env fix in
+  for i = 0 to Array.length bodies - 1 do
+    let (fenv,body) = rdef.(i) in
+    let renv = make_renv fenv minds nvect.(i) minds.(i) in
+    try
+      let _ = check_one_fix renv nvect body in ()
+    with FixGuardError (fixenv,err) ->
+      error_ill_formed_rec_body fixenv err names i
+  done
+
+(*
+let cfkey = Profile.declare_profile "check_fix";;
+let check_fix env fix = Profile.profile3 cfkey check_fix env fix;;
+*)
+
+(************************************************************************)
+(* Scrape *)
+
+let rec scrape_mind env kn = 
+  match (Environ.lookup_mind kn env).mind_equiv with
+    | None -> kn
+    | Some kn' -> scrape_mind env kn'
+
+(************************************************************************)
+(* Co-fixpoints. *)
+
+exception CoFixGuardError of env * guard_error
+
+let anomaly_ill_typed () =
+  anomaly "check_one_cofix: too many arguments applied to constructor"
+
+let rec codomain_is_coind env c =
+  let b = whd_betadeltaiota env c in
+  match kind_of_term b with
+    | Prod (x,a,b) ->
+	codomain_is_coind (push_rel (x, None, a) env) b 
+    | _ -> 
+	(try find_coinductive env b
+        with Not_found ->
+	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
+
+let check_one_cofix env nbfix def deftype = 
+  let rec check_rec_call env alreadygrd n vlra  t =
+    if noccur_with_meta n nbfix t then
+      true 
+    else
+      let c,args = decompose_app (whd_betadeltaiota env t) in
+      match kind_of_term c with 
+	| Meta _ -> true
+	      
+	| Rel p when  n <= p && p < n+nbfix ->
+	    (* recursive call *)
+            if alreadygrd then
+	      if List.for_all (noccur_with_meta n nbfix) args then
+		true
+	      else 
+		raise (CoFixGuardError (env,NestedRecursiveOccurrences))
+            else 
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
+		 
+	| Construct (_,i as cstr_kn)  ->
+            let lra =vlra.(i-1) in 
+            let mI = inductive_of_constructor cstr_kn in
+	    let (mib,mip) = lookup_mind_specif env mI in
+            let realargs = list_skipn mip.mind_nparams args in
+            let rec process_args_of_constr = function
+              | (t::lr), (rar::lrar) -> 
+                  if rar = mk_norec then
+                    if noccur_with_meta n nbfix t
+                    then process_args_of_constr (lr, lrar)
+                    else raise (CoFixGuardError
+		                 (env,RecCallInNonRecArgOfConstructor t))
+                  else
+                    let spec = dest_subterms rar in
+                    check_rec_call env true n spec t &&
+                    process_args_of_constr (lr, lrar)
+              | [],_ -> true 
+              | _ -> anomaly_ill_typed () 
+            in process_args_of_constr (realargs, lra)
+		 
+	| Lambda (x,a,b) ->
+	     assert (args = []);
+            if (noccur_with_meta n nbfix a) then
+              check_rec_call (push_rel (x, None, a) env)
+		alreadygrd (n+1)  vlra b
+            else 
+	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
+	      
+	| CoFix (j,(_,varit,vdefs as recdef)) ->
+            if (List.for_all (noccur_with_meta n nbfix) args)
+            then 
+              let nbfix = Array.length vdefs in
+	      if (array_for_all (noccur_with_meta n nbfix) varit) then
+		let env' = push_rec_types recdef env in
+		(array_for_all
+		   (check_rec_call env' alreadygrd (n+1) vlra) vdefs)
+		&&
+		(List.for_all (check_rec_call env alreadygrd (n+1) vlra) args) 
+              else 
+		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
+	    else
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
+
+	| Case (_,p,tm,vrest) ->
+            if (noccur_with_meta n nbfix p) then
+              if (noccur_with_meta n nbfix tm) then
+		if (List.for_all (noccur_with_meta n nbfix) args) then
+		  (array_for_all (check_rec_call env alreadygrd n vlra) vrest)
+		else 
+		  raise (CoFixGuardError (env,RecCallInCaseFun c))
+              else 
+		raise (CoFixGuardError (env,RecCallInCaseArg c))
+            else 
+	      raise (CoFixGuardError (env,RecCallInCasePred c))
+              
+	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in 
+  let (mind, _) = codomain_is_coind env deftype in
+  let vlra = lookup_subterms env mind in
+  check_rec_call env false 1 (dest_subterms vlra) def
+
+(* The  function which checks that the whole block of definitions 
+   satisfies the guarded condition *)
+
+let check_cofix env (bodynum,(names,types,bodies as recdef)) = 
+  let nbfix = Array.length bodies in 
+  for i = 0 to nbfix-1 do
+    let fixenv = push_rec_types recdef env in
+    try 
+      let _ = check_one_cofix fixenv nbfix bodies.(i) types.(i)
+      in ()
+    with CoFixGuardError (errenv,err) -> 
+      error_ill_formed_rec_body errenv err names i
+  done
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
new file mode 100644
index 00000000..ad44fa64
--- /dev/null
+++ b/kernel/inductive.mli
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  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: inductive.mli,v 1.57.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+(*i*)
+
+(*s Extracting an inductive type from a construction *)
+
+(* [find_m*type env sigma c] coerce [c] to an recursive type (I args).
+   [find_rectype], [find_inductive] and [find_coinductive]
+   respectively accepts any recursive type, only an inductive type and
+   only a coinductive type.
+   They raise [Not_found] if not convertible to a recursive type. *)
+
+val find_rectype     : env -> types -> inductive * constr list
+val find_inductive   : env -> types -> inductive * constr list
+val find_coinductive : env -> types -> inductive * constr list
+
+(*s Fetching information in the environment about an inductive type.
+    Raises [Not_found] if the inductive type is not found. *)
+val lookup_mind_specif :
+  env -> inductive -> mutual_inductive_body * one_inductive_body
+
+(*s Functions to build standard types related to inductive *)
+
+val type_of_inductive    : env -> inductive -> types
+
+(* Return type as quoted by the user *)
+val type_of_constructor  : env -> constructor -> types
+
+(* Return constructor types in normal form *)
+val arities_of_constructors : env -> inductive -> types array
+
+(* Transforms inductive specification into types (in nf) *)
+val arities_of_specif : mutual_inductive -> 
+  mutual_inductive_body * one_inductive_body -> types array 
+
+(* [type_case_branches env (I,args) (p:A) c] computes useful types
+   about the following Cases expression:
+      <p>Cases (c :: (I args)) of b1..bn end
+   It computes the type of every branch (pattern variables are
+   introduced by products), the type for the whole expression, and
+   the universe constraints generated.
+ *)
+val type_case_branches :
+  env -> inductive * constr list -> unsafe_judgment -> constr
+    -> types array * types * constraints
+
+(* Check a [case_info] actually correspond to a Case expression on the
+   given inductive type. *)
+val check_case_info : env -> inductive -> case_info -> unit
+
+(* Find the ultimate inductive in the mind_equiv chain *)
+
+val scrape_mind : env -> mutual_inductive -> mutual_inductive
+
+(*s Guard conditions for fix and cofix-points. *)
+val check_fix : env -> fixpoint -> unit
+val check_cofix : env -> cofixpoint -> unit
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
new file mode 100644
index 00000000..5e8c7001
--- /dev/null
+++ b/kernel/mod_typing.ml
@@ -0,0 +1,324 @@
+(************************************************************************)
+(*  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: mod_typing.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+open Util
+open Names
+open Univ
+open Declarations
+open Entries
+open Environ
+open Term_typing
+open Modops
+open Subtyping
+
+exception Not_path
+
+let path_of_mexpr = function
+  | MEident mb -> mb
+  | _ -> raise Not_path
+
+let rec replace_first p k = function 
+  | [] -> [] 
+  | h::t when p h -> k::t
+  | h::t -> h::(replace_first p k t)
+
+let rec list_split_assoc k rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' -> rev_before,b,after
+  | h::tail -> list_split_assoc k (h::rev_before) tail
+
+let rec list_fold_map2 f e = function 
+  |  []  -> (e,[],[])
+  |  h::t -> 
+       let e',h1',h2' = f e h in
+       let e'',t1',t2' = list_fold_map2 f e' t in
+	 e'',h1'::t1',h2'::t2'
+
+let type_modpath env mp = 
+  strengthen env (lookup_module mp env).mod_type mp
+
+let rec translate_modtype env mte =
+  match mte with
+    | MTEident ln -> MTBident ln
+    | MTEfunsig (arg_id,arg_e,body_e) -> 
+	let arg_b = translate_modtype env arg_e in
+	let env' = 
+	  add_module (MPbound arg_id) (module_body_of_type arg_b) env in
+	let body_b = translate_modtype env' body_e in
+	  MTBfunsig (arg_id,arg_b,body_b)
+    | MTEsig (msid,sig_e) ->
+	let str_b,sig_b = translate_entry_list env msid false sig_e in
+	  MTBsig (msid,sig_b)
+    | MTEwith (mte, with_decl) ->
+	let mtb = translate_modtype env mte in
+	  merge_with env mtb with_decl
+
+and merge_with env mtb with_decl = 
+  let msid,sig_b = match (Modops.scrape_modtype env mtb) with 
+    | MTBsig(msid,sig_b) -> msid,sig_b 
+    | _ -> error_signature_expected mtb
+  in
+  let id = match with_decl with 
+    | With_Definition (id,_) | With_Module (id,_) -> id
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let env' = Modops.add_signature (MPself msid) before env in
+      let new_spec = match with_decl with
+	| With_Definition (id,c) -> 
+	    let cb = match spec with
+		SPBconst cb -> cb
+	      | _ -> error_not_a_constant l
+	    in 
+	      begin
+		match cb.const_body with
+		  | None -> 
+		      let (j,cst1) = Typeops.infer env' c in
+		      let cst2 = 
+			Reduction.conv_leq env' j.uj_type cb.const_type in
+		      let cst = 
+			Constraint.union 
+			  (Constraint.union cb.const_constraints cst1)
+			  cst2
+		      in
+			SPBconst {cb with 
+				    const_body = 
+				      Some (Declarations.from_val j.uj_val);
+				    const_constraints = cst}
+		  | Some b -> 
+		      let cst1 = Reduction.conv env' c (Declarations.force b) in
+		      let cst = Constraint.union cb.const_constraints cst1 in
+			SPBconst {cb with 
+				    const_body = Some (Declarations.from_val c);
+				    const_constraints = cst}
+	      end	
+(* and what about msid's ????? Don't they clash ? *)
+	| With_Module (id, mp) ->
+	    let old = match spec with
+		SPBmodule msb -> msb
+	      | _ -> error_not_a_module (string_of_label l)
+	    in
+	    let mtb = type_modpath env' mp in
+	 (* here, using assertions in substitutions, 
+	    we check that there is no msid bound in mtb *)
+	    begin
+	      try 
+		let _ = subst_modtype (map_msid msid (MPself msid)) mtb in
+		  ()
+	      with
+		  Failure _ -> error_circular_with_module id
+	    end;
+	    let cst =
+              try check_subtypes env' mtb old.msb_modtype
+              with Failure _ -> error_with_incorrect (label_of_id id) in
+	    let equiv = 
+ 	      match old.msb_equiv with
+		| None -> Some mp
+		| Some mp' -> 
+		    check_modpath_equiv env' mp mp';
+		    Some mp
+	    in
+	    let msb =
+	      {msb_modtype = mtb; 
+	       msb_equiv = equiv; 
+	       msb_constraints = Constraint.union old.msb_constraints cst }
+	    in
+	      SPBmodule msb
+      in
+	MTBsig(msid,  before@(l,new_spec)::after)
+    with
+	Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_with_incorrect l
+
+and translate_entry_list env msid is_definition sig_e = 
+  let mp = MPself msid in
+  let do_entry env (l,e) = 
+    let kn = make_kn mp empty_dirpath l in
+    match e with
+      | SPEconst ce ->
+	  let cb = translate_constant env ce in
+	    begin match cb.const_hyps with
+	      |	(_::_) -> error_local_context (Some l)
+	      | [] ->
+		  add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb)
+	    end
+      | SPEmind mie -> 
+	  let mib = translate_mind env mie in
+	    begin match mib.mind_hyps with
+	      |	(_::_) -> error_local_context (Some l)
+	      | [] ->
+		  add_mind kn mib env, (l, SEBmind mib), (l, SPBmind mib)
+	    end
+      | SPEmodule me ->
+	  let mb = translate_module env is_definition me in
+	  let mspec = 
+	    { msb_modtype = mb.mod_type;
+	      msb_equiv = mb.mod_equiv;
+	      msb_constraints = mb.mod_constraints }
+	  in
+	  let mp' = MPdot (mp,l) in
+	    add_module mp' mb env, (l, SEBmodule mb), (l, SPBmodule mspec)
+      | SPEmodtype mte ->
+	  let mtb = translate_modtype env mte in
+	    add_modtype kn mtb env, (l, SEBmodtype mtb), (l, SPBmodtype mtb)
+  in
+  let _,str_b,sig_b = list_fold_map2 do_entry env sig_e
+  in
+    str_b,sig_b
+
+(* if [is_definition=true], [mod_entry_expr] may be any expression.
+   Otherwise it must be a path *)
+
+and translate_module env is_definition me =
+  match me.mod_entry_expr, me.mod_entry_type with
+    | None, None -> 
+	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
+    | None, Some mte -> 
+	let mtb = translate_modtype env mte in
+	{ mod_expr = None;
+	  mod_user_type = Some mtb;
+	  mod_type = mtb;
+	  mod_equiv = None;
+	  mod_constraints = Constraint.empty }
+    | Some mexpr, _ -> 
+	let meq_o = (* do we have a transparent module ? *)
+	  try       (* TODO: transparent field in module_entry *)
+	    match me.mod_entry_type with
+	      | None -> Some (path_of_mexpr mexpr)
+	      | Some _ -> None
+	  with 
+	    | Not_path -> None
+	in
+	let meb,mtb1 = 
+	  if is_definition then
+	    translate_mexpr env mexpr
+	  else 
+	    let mp = 
+	      try 
+		path_of_mexpr mexpr 
+	      with 
+		| Not_path -> error_declaration_not_path mexpr
+	    in
+	      MEBident mp, type_modpath env mp
+	in
+	let mtb, mod_user_type, cst =
+	  match me.mod_entry_type with
+	    | None -> mtb1, None, Constraint.empty
+	    | Some mte -> 
+		let mtb2 = translate_modtype env mte in
+                let cst =
+                  try check_subtypes env mtb1 mtb2
+                  with Failure _ -> error "not subtype" in
+		mtb2, Some mtb2, cst
+	in
+	  { mod_type = mtb;
+	    mod_user_type = mod_user_type;
+	    mod_expr = Some meb;
+	    mod_equiv = meq_o;
+	    mod_constraints = cst }
+
+(* translate_mexpr : env -> module_expr -> module_expr_body * module_type_body *)
+and translate_mexpr env mexpr = match mexpr with
+  | MEident mp -> 
+      MEBident mp,
+      type_modpath env mp
+  | MEfunctor (arg_id, arg_e, body_expr) ->
+      let arg_b = translate_modtype env arg_e in
+      let env' = add_module (MPbound arg_id) (module_body_of_type arg_b) env in
+      let (body_b,body_tb) = translate_mexpr env' body_expr in
+	MEBfunctor (arg_id, arg_b, body_b), 
+	MTBfunsig (arg_id, arg_b, body_tb)
+  | MEapply (fexpr,mexpr) ->
+      let feb,ftb = translate_mexpr env fexpr in
+      let ftb = scrape_modtype env ftb in
+      let farg_id, farg_b, fbody_b = destr_functor ftb in
+      let meb,mtb = translate_mexpr env mexpr in
+      let cst =
+        try check_subtypes env mtb farg_b
+        with Failure _ ->
+          error "" in
+      let mp = 
+	try
+	  path_of_mexpr mexpr 
+	with
+	  | Not_path -> error_application_to_not_path mexpr
+	      (* place for nondep_supertype *)
+      in
+	MEBapply(feb,meb,cst),
+	subst_modtype (map_mbid farg_id mp) fbody_b
+  | MEstruct (msid,structure) ->
+      let structure,signature = translate_entry_list env msid true structure in
+	MEBstruct (msid,structure),
+	MTBsig (msid,signature)
+
+
+(* is_definition is true - me.mod_entry_expr may be any expression *)
+let translate_module env me = translate_module env true me
+
+let rec add_module_expr_constraints env = function
+  | MEBident _ -> env
+
+  | MEBfunctor (_,mtb,meb) -> 
+      add_module_expr_constraints (add_modtype_constraints env mtb) meb
+
+  | MEBstruct (_,mod_struct_body) ->
+      List.fold_left 
+        (fun env (l,item) -> add_struct_elem_constraints env item)
+        env
+        mod_struct_body
+
+  | MEBapply (meb1,meb2,cst) ->
+      Environ.add_constraints cst 
+        (add_module_expr_constraints 
+	  (add_module_expr_constraints env meb1) 
+	  meb2)
+
+and add_struct_elem_constraints env = function 
+  | SEBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SEBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SEBmodule mb -> add_module_constraints env mb
+  | SEBmodtype mtb -> add_modtype_constraints env mtb
+
+and add_module_constraints env mb = 
+  (* if there is a body, the mb.mod_type is either inferred from the
+     body and hence uninteresting or equal to the non-empty
+     user_mod_type *)
+  let env = match mb.mod_expr with
+    | None -> add_modtype_constraints env mb.mod_type
+    | Some meb -> add_module_expr_constraints env meb
+  in
+  let env = match mb.mod_user_type with
+    | None -> env
+    | Some mtb -> add_modtype_constraints env mtb
+  in
+    Environ.add_constraints mb.mod_constraints env
+
+and add_modtype_constraints env = function
+  | MTBident _ -> env
+  | MTBfunsig (_,mtb1,mtb2) ->
+      add_modtype_constraints
+        (add_modtype_constraints env mtb1)
+        mtb2
+  | MTBsig (_,mod_sig_body) ->
+      List.fold_left 
+        (fun env (l,item) -> add_sig_elem_constraints env item)
+        env
+        mod_sig_body
+
+and add_sig_elem_constraints env = function 
+  | SPBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SPBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SPBmodule {msb_modtype=mtb; msb_constraints=cst} -> 
+      add_modtype_constraints (Environ.add_constraints cst env) mtb
+  | SPBmodtype mtb -> add_modtype_constraints env mtb
+
+
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
new file mode 100644
index 00000000..0ea98bf0
--- /dev/null
+++ b/kernel/mod_typing.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        *)
+(************************************************************************)
+
+(* $Id: mod_typing.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+(*i*)
+open Declarations
+open Environ
+open Entries
+(*i*)
+
+
+val translate_modtype : env -> module_type_entry -> module_type_body
+
+val translate_module : env -> module_entry -> module_body
+
+val add_modtype_constraints : env -> module_type_body -> env
+
+val add_module_constraints : env -> module_body -> env
+
diff --git a/kernel/modops.ml b/kernel/modops.ml
new file mode 100644
index 00000000..84845af5
--- /dev/null
+++ b/kernel/modops.ml
@@ -0,0 +1,245 @@
+(************************************************************************)
+(*  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: modops.ml,v 1.12.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Pp
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Entries
+(*i*)
+
+let error_existing_label l = 
+  error ("The label "^string_of_label l^" is already declared")
+
+let error_declaration_not_path _ = error "Declaration is not a path"
+
+let error_application_to_not_path _ = error "Application to not path"
+
+let error_not_a_functor _ = error "Application of not a functor"
+
+let error_incompatible_modtypes _ _ = error "Incompatible module types"
+
+let error_not_equal _ _ = error "Not equal modules"
+
+let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match")
+
+let error_no_such_label l = error ("No such label "^string_of_label l)
+
+let error_incompatible_labels l l' = 
+  error ("Opening and closing labels are not the same: "
+	 ^string_of_label l^" <> "^string_of_label l'^" !")
+
+let error_result_must_be_signature mtb = 
+  error "The result module type must be a signature"
+
+let error_signature_expected mtb =
+  error "Signature expected"
+
+let error_no_module_to_end _ = 
+  error "No open module to end"
+
+let error_no_modtype_to_end _ =
+  error "No open module type to end"
+
+let error_not_a_modtype_loc loc s = 
+  user_err_loc (loc,"",str ("\""^s^"\" is not a module type"))
+
+let error_not_a_module_loc loc s = 
+  user_err_loc (loc,"",str ("\""^s^"\" is not a module"))
+
+let error_not_a_module s = error_not_a_module_loc dummy_loc s
+
+let error_not_a_constant l = 
+  error ("\""^(string_of_label l)^"\" is not a constant")
+
+let error_with_incorrect l =
+  error ("Incorrect constraint for label \""^(string_of_label l)^"\"")
+
+let error_local_context lo = 
+  match lo with
+      None -> 
+	error ("The local context is not empty.")
+    | (Some l) ->
+	error ("The local context of the component "^
+	       (string_of_label l)^" is not empty")
+
+let error_circular_with_module l =
+  error ("The construction \"with Module "^(string_of_id l)^":=...\" is about to create\na circular module type. Their resolution is not implemented yet.\nIf you really need that feature, please report.")
+
+let rec scrape_modtype env = function
+  | MTBident kn -> scrape_modtype env (lookup_modtype kn env)
+  | mtb -> mtb
+
+(* the constraints are not important here *)
+let module_body_of_spec msb = 
+    { mod_type = msb.msb_modtype;
+      mod_equiv = msb.msb_equiv;
+      mod_expr = None;
+      mod_user_type = None;
+      mod_constraints = Constraint.empty}
+
+let module_body_of_type mtb = 
+  { mod_type = mtb;
+    mod_equiv = None;
+    mod_expr = None;
+    mod_user_type = None;
+    mod_constraints = Constraint.empty}
+
+
+(* the constraints are not important here *)
+let module_spec_of_body mb = 
+  { msb_modtype = mb.mod_type; 
+    msb_equiv = mb.mod_equiv; 
+    msb_constraints = Constraint.empty}
+
+
+
+let destr_functor = function
+  | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
+  | mtb -> error_not_a_functor mtb
+ 
+
+let rec check_modpath_equiv env mp1 mp2 = 
+  if mp1=mp2 then () else
+  let mb1 = lookup_module mp1 env in
+    match mb1.mod_equiv with
+      | None ->
+	  let mb2 = lookup_module mp2 env in
+	    (match mb2.mod_equiv with
+	      | None -> error_not_equal mp1 mp2
+	      | Some mp2' -> check_modpath_equiv env mp2' mp1)
+      | Some mp1' -> check_modpath_equiv env mp2 mp1'
+
+
+let rec subst_modtype sub = function
+  | MTBident ln -> MTBident (subst_kn sub ln)
+  | MTBfunsig (arg_id, arg_b, body_b) ->
+      if occur_mbid arg_id sub then failwith "capture";
+      MTBfunsig (arg_id, 
+		 subst_modtype sub arg_b, 
+		 subst_modtype sub body_b)
+  | MTBsig (sid1, msb) -> 
+      if occur_msid sid1 sub then failwith "capture";
+      MTBsig (sid1, subst_signature sub msb)
+
+and subst_signature sub sign = 
+  let subst_body = function
+      SPBconst cb -> 
+	SPBconst (subst_const_body sub cb)
+    | SPBmind mib -> 
+	SPBmind (subst_mind sub mib)
+    | SPBmodule mb -> 
+	SPBmodule (subst_module sub mb)
+    | SPBmodtype mtb -> 
+	SPBmodtype (subst_modtype sub mtb)
+  in
+    List.map (fun (l,b) -> (l,subst_body b)) sign
+
+and subst_module sub mb =
+  let mtb' = subst_modtype sub mb.msb_modtype in
+  let mpo' = option_smartmap (subst_mp sub) mb.msb_equiv in
+    if mtb'==mb.msb_modtype && mpo'==mb.msb_equiv then mb else
+      { msb_modtype=mtb'; 
+	msb_equiv=mpo'; 
+	msb_constraints=mb.msb_constraints}
+
+
+let subst_signature_msid msid mp = 
+  subst_signature (map_msid msid mp)
+
+(* we assume that the substitution of "mp" into "msid" is already done
+(or unnecessary) *)
+let rec add_signature mp sign env = 
+  let add_one env (l,elem) =
+    let kn = make_kn mp empty_dirpath l in
+      match elem with
+	| SPBconst cb -> Environ.add_constant kn cb env
+	| SPBmind mib -> Environ.add_mind kn mib env
+	| SPBmodule mb -> 
+	    add_module (MPdot (mp,l)) (module_body_of_spec mb) env 
+	    (* adds components as well *)
+	| SPBmodtype mtb -> Environ.add_modtype kn mtb env
+  in
+    List.fold_left add_one env sign
+
+
+and add_module mp mb env = 
+  let env = Environ.shallow_add_module mp mb env in
+    match scrape_modtype env mb.mod_type with
+      | MTBident _ -> anomaly "scrape_modtype does not work!"
+      | MTBsig (msid,sign) -> 
+	  add_signature mp (subst_signature_msid msid mp sign) env
+
+      | MTBfunsig _ -> env
+
+
+let strengthen_const env mp l cb = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None -> 
+      let const = mkConst (make_kn mp empty_dirpath l) in 
+      let const_subs = Some (Declarations.from_val const) in
+	{cb with 
+      	   const_body = const_subs;
+	   const_opaque = false
+	}
+
+let strengthen_mind env mp l mib = match mib.mind_equiv with
+  | Some _ -> mib
+  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
+    
+let rec strengthen_mtb env mp mtb = match scrape_modtype env mtb with
+  | MTBident _ -> anomaly "scrape_modtype does not work!"
+  | MTBfunsig _ -> mtb
+  | MTBsig (msid,sign) -> MTBsig (msid,strengthen_sig env msid sign mp)
+
+and strengthen_mod env mp msb = 
+  { msb_modtype = strengthen_mtb env mp msb.msb_modtype;
+    msb_equiv = begin match msb.msb_equiv with
+      | Some _ -> msb.msb_equiv
+      | None -> Some mp 
+    end ;
+    msb_constraints = msb.msb_constraints; }
+
+and strengthen_sig env msid sign mp = match sign with
+  | [] -> []
+  | (l,SPBconst cb) :: rest ->
+      let item' = l,SPBconst (strengthen_const env mp l cb) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmind mib) :: rest ->
+      let item' = l,SPBmind (strengthen_mind env mp l mib) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmodule mb) :: rest ->
+      let mp' = MPdot (mp,l) in
+      let item' = l,SPBmodule (strengthen_mod env mp' mb) in
+      let env' = add_module 
+		   (MPdot (MPself msid,l)) 
+		   (module_body_of_spec mb) 
+		   env 
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item'::rest'
+  | (l,SPBmodtype mty as item) :: rest -> 
+      let env' = add_modtype 
+		   (make_kn (MPself msid) empty_dirpath l) 
+		   mty
+		   env
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item::rest'
+
+let strengthen env mtb mp = strengthen_mtb env mp mtb
diff --git a/kernel/modops.mli b/kernel/modops.mli
new file mode 100644
index 00000000..5433fa3e
--- /dev/null
+++ b/kernel/modops.mli
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  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: modops.mli,v 1.7.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Environ
+open Declarations
+open Entries
+(*i*)
+
+(* Various operations on modules and module types *)
+
+(* recursively unfold MTBdent module types *)
+val scrape_modtype : env -> module_type_body -> module_type_body
+
+(* make the environment entry out of type *)
+val module_body_of_type : module_type_body -> module_body
+
+val module_body_of_spec : module_specification_body -> module_body 
+
+val module_spec_of_body : module_body -> module_specification_body
+
+
+val destr_functor : 
+  module_type_body -> mod_bound_id * module_type_body * module_type_body
+
+
+val subst_modtype : substitution -> module_type_body -> module_type_body
+
+val subst_signature_msid :
+  mod_self_id -> module_path -> 
+  module_signature_body -> module_signature_body
+
+(* [add_signature mp sign env] assumes that the substitution [msid]
+   \mapsto [mp] has already been performed (or is not necessary, like
+   when [mp = MPself msid]) *)
+val add_signature : 
+  module_path -> module_signature_body -> env -> env
+
+(* adds a module and its components, but not the constraints *)
+val add_module :
+  module_path -> module_body -> env -> env
+
+val check_modpath_equiv : env -> module_path -> module_path -> unit
+
+val strengthen : env -> module_type_body -> module_path -> module_type_body
+
+val error_existing_label : label -> 'a
+
+val error_declaration_not_path : module_expr -> 'a
+
+val error_application_to_not_path : module_expr -> 'a
+
+val error_not_a_functor : module_expr -> 'a
+
+val error_incompatible_modtypes : 
+  module_type_body -> module_type_body -> 'a
+
+val error_not_equal : module_path -> module_path -> 'a
+
+val error_not_match : label -> specification_body -> 'a
+  
+val error_incompatible_labels : label -> label -> 'a
+
+val error_no_such_label : label -> 'a
+
+val error_result_must_be_signature : module_type_body -> 'a
+
+val error_signature_expected : module_type_body -> 'a
+
+val error_no_module_to_end : unit -> 'a 
+
+val error_no_modtype_to_end : unit -> 'a
+
+val error_not_a_modtype_loc : loc -> string -> 'a 
+
+val error_not_a_module_loc : loc -> string -> 'a 
+
+val error_not_a_module : string -> 'a 
+
+val error_not_a_constant : label -> 'a
+
+val error_with_incorrect : label -> 'a
+
+val error_local_context : label option -> 'a
+
+val error_circular_with_module : identifier -> 'a
diff --git a/kernel/names.ml b/kernel/names.ml
new file mode 100644
index 00000000..df3a012f
--- /dev/null
+++ b/kernel/names.ml
@@ -0,0 +1,355 @@
+(************************************************************************)
+(*  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: names.ml,v 1.53.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Pp
+open Util
+
+(*s Identifiers *)
+
+type identifier = string
+
+let id_ord = Pervasives.compare
+
+let id_of_string s = String.copy s
+
+let map_ident id =
+  if Options.do_translate() then
+    match id with
+        "fix" -> "Fix"
+      | _ -> id
+  else id
+let string_of_id id = String.copy (map_ident id)
+
+(* Hash-consing of identifier *)
+module Hident = Hashcons.Make(
+  struct 
+    type t = string
+    type u = string -> string
+    let hash_sub hstr id = hstr id
+    let equal id1 id2 = id1 == id2
+    let hash = Hashtbl.hash
+  end)
+
+module IdOrdered = 
+  struct
+    type t = identifier
+    let compare = id_ord
+  end
+
+module Idset = Set.Make(IdOrdered)
+module Idmap = Map.Make(IdOrdered)
+module Idpred = Predicate.Make(IdOrdered)
+
+(* Names *)
+
+type name = Name of identifier | Anonymous
+
+(* Dirpaths are lists of module identifiers. The actual representation
+   is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
+ 
+type module_ident = identifier
+type dir_path = module_ident list
+
+module ModIdOrdered = 
+  struct
+    type t = identifier
+    let compare = Pervasives.compare
+  end
+
+module ModIdmap = Map.Make(ModIdOrdered)
+
+let make_dirpath x = x
+let repr_dirpath x = x
+
+let empty_dirpath = []
+
+let string_of_dirpath = function
+  | [] -> "<empty>"
+  | sl ->
+      String.concat "." (List.map string_of_id (List.rev sl))
+
+
+let u_number = ref 0 
+type uniq_ident = int * string * dir_path
+let make_uid dir s = incr u_number;(!u_number,String.copy s,dir)
+let string_of_uid (i,s,p) = 
+  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+
+module Umap = Map.Make(struct 
+			 type t = uniq_ident 
+			 let compare = Pervasives.compare
+		       end)
+
+
+type mod_self_id = uniq_ident
+let make_msid = make_uid
+let debug_string_of_msid = string_of_uid
+let id_of_msid (_,s,_) = s
+
+type mod_bound_id = uniq_ident
+let make_mbid = make_uid
+let debug_string_of_mbid = string_of_uid
+let id_of_mbid (_,s,_) = s
+
+type label = string
+let mk_label l = l
+let string_of_label l = l
+
+let id_of_label l = l
+let label_of_id id = id
+
+module Labset = Idset
+module Labmap = Idmap
+
+type module_path =
+  | MPfile of dir_path
+  | MPbound of mod_bound_id
+  | MPself of mod_self_id 
+  | MPdot of module_path * label
+
+let rec string_of_mp = function
+  | MPfile sl -> string_of_dirpath sl
+  | MPbound uid -> string_of_uid uid
+  | MPself uid -> string_of_uid uid
+  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
+
+(* we compare labels first if both are MPdots *)
+let rec mp_ord mp1 mp2 = match (mp1,mp2) with
+    MPdot(mp1,l1), MPdot(mp2,l2) -> 
+      let c = Pervasives.compare l1 l2 in
+	if c<>0 then
+	  c
+	else
+	  mp_ord mp1 mp2
+  |  _,_ -> Pervasives.compare mp1 mp2
+
+module MPord = struct
+  type t = module_path
+  let compare = mp_ord
+end
+
+module MPset = Set.Make(MPord)
+module MPmap = Map.Make(MPord)
+
+
+(* this is correct under the condition that bound and struct
+   identifiers can never be identical (i.e. get the same stamp)! *) 
+
+type substitution = module_path Umap.t
+
+let empty_subst = Umap.empty
+
+let add_msid = Umap.add 
+let add_mbid = Umap.add
+
+let map_msid msid mp = add_msid msid mp empty_subst
+let map_mbid mbid mp = add_msid mbid mp empty_subst
+
+let list_contents sub = 
+  let one_pair uid mp l =
+    (string_of_uid uid, string_of_mp mp)::l
+  in
+    Umap.fold one_pair sub []
+
+let debug_string_of_subst sub = 
+  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
+    "{" ^ String.concat "; " l ^ "}"
+
+let debug_pr_subst sub = 
+  let l = list_contents sub in
+  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
+  in
+    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
+
+let rec subst_mp sub mp = (* 's like subst *)
+  match mp with
+    | MPself sid -> 
+	(try Umap.find sid sub with Not_found -> mp)
+    | MPbound bid ->
+	(try Umap.find bid sub with Not_found -> mp)
+    | MPdot (mp1,l) -> 
+	let mp1' = subst_mp sub mp1 in
+	  if mp1==mp1' then 
+	    mp
+	  else
+	    MPdot (mp1',l)
+    | _ -> mp
+
+let join subst1 subst2 = 
+  let subst = Umap.map (subst_mp subst2) subst1 in
+  Umap.fold Umap.add subst2 subst
+
+let rec occur_in_path uid = function
+  | MPself sid -> sid = uid
+  | MPbound bid -> bid = uid
+  | MPdot (mp1,_) -> occur_in_path uid mp1
+  | _ -> false
+    
+let occur_uid uid sub = 
+  let check_one uid' mp =
+    if uid = uid' || occur_in_path uid mp then raise Exit
+  in
+    try 
+      Umap.iter check_one sub;
+      false
+    with Exit -> true
+
+let occur_msid = occur_uid
+let occur_mbid = occur_uid
+
+
+
+(* Kernel names *)
+
+type kernel_name = module_path * dir_path * label
+
+let make_kn mp dir l = (mp,dir,l)
+let repr_kn kn = kn
+
+let modpath kn = 
+  let mp,_,_ = repr_kn kn in mp
+
+let label kn = 
+  let _,_,l = repr_kn kn in l
+
+let string_of_kn (mp,dir,l) = 
+  string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l
+
+let pr_kn kn = str (string_of_kn kn)
+
+
+let subst_kn sub (mp,dir,l as kn) = 
+  let mp' = subst_mp sub mp in
+    if mp==mp' then kn else (mp',dir,l)
+
+
+let kn_ord kn1 kn2 = 
+    let mp1,dir1,l1 = kn1 in
+    let mp2,dir2,l2 = kn2 in
+    let c = Pervasives.compare l1 l2 in
+      if c <> 0 then
+	c
+      else 
+	let c = Pervasives.compare dir1 dir2 in
+	  if c<>0 then
+	    c 
+	  else
+	    MPord.compare mp1 mp2
+
+
+module KNord = struct
+  type t = kernel_name
+  let compare =kn_ord
+end
+
+module KNmap = Map.Make(KNord)
+module KNpred = Predicate.Make(KNord)
+module KNset = Set.Make(KNord)
+
+
+let default_module_name = id_of_string "If you see this, it's a bug"
+
+let initial_dir = make_dirpath [default_module_name]
+
+let initial_msid = (make_msid initial_dir "If you see this, it's a bug")
+let initial_path = MPself initial_msid
+
+type variable = identifier
+type constant = kernel_name
+type mutual_inductive = kernel_name
+type inductive = mutual_inductive * int
+type constructor = inductive * int
+
+let ith_mutual_inductive (kn,_) i = (kn,i)
+let ith_constructor_of_inductive ind i = (ind,i)
+let inductive_of_constructor (ind,i) = ind
+let index_of_constructor (ind,i) = i
+
+(* Better to have it here that in closure, since used in grammar.cma *)
+type evaluable_global_reference =
+  | EvalVarRef of identifier
+  | EvalConstRef of constant
+
+(* Hash-consing of name objects *)
+module Hname = Hashcons.Make(
+  struct 
+    type t = name
+    type u = identifier -> identifier
+    let hash_sub hident = function
+      | Name id -> Name (hident id)
+      | n -> n
+    let equal n1 n2 =
+      match (n1,n2) with
+	| (Name id1, Name id2) -> id1 == id2
+        | (Anonymous,Anonymous) -> true
+        | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Hdir = Hashcons.Make(
+  struct 
+    type t = dir_path
+    type u = identifier -> identifier
+    let hash_sub hident d = List.map hident d
+    let rec equal d1 d2 = match (d1,d2) with
+      | [],[] -> true
+      | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
+      | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Huniqid = Hashcons.Make(
+  struct 
+    type t = uniq_ident
+    type u = (string -> string) * (dir_path -> dir_path)
+    let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir)
+    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2
+    let hash = Hashtbl.hash
+  end)
+
+module Hmod = Hashcons.Make(
+  struct 
+    type t = module_path
+    type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) *
+	(string -> string)
+    let rec hash_sub (hdir,huniqid,hstr as hfuns) = function
+      | MPfile dir -> MPfile (hdir dir)
+      | MPbound m -> MPbound (huniqid m)
+      | MPself m -> MPself (huniqid m)
+      | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l)
+    let rec equal d1 d2 = match (d1,d2) with
+      | MPfile dir1, MPfile dir2 -> dir1 == dir2
+      | MPbound m1, MPbound m2 -> m1 == m2
+      | MPself m1, MPself m2 -> m1 == m2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
+      | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Hkn = Hashcons.Make(
+  struct 
+    type t = kernel_name
+    type u = (module_path -> module_path)
+	* (dir_path -> dir_path) * (string -> string)
+    let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l)
+    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
+      mod1 == mod2 && dir1 == dir2 && l1 == l2
+    let hash = Hashtbl.hash
+  end)
+
+let hcons_names () =
+  let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in
+  let hident = Hashcons.simple_hcons Hident.f hstring in
+  let hname = Hashcons.simple_hcons Hname.f hident in
+  let hdir = Hashcons.simple_hcons Hdir.f hident in
+  let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in
+  let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in
+  let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in
+  (hkn,hdir,hname,hident,hstring)
diff --git a/kernel/names.mli b/kernel/names.mli
new file mode 100644
index 00000000..07c19841
--- /dev/null
+++ b/kernel/names.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: names.mli,v 1.46.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*s Identifiers *)
+
+type identifier
+type name = Name of identifier | Anonymous
+(* Parsing and printing of identifiers *)
+val string_of_id : identifier -> string
+val id_of_string : string -> identifier
+
+val id_ord : identifier -> identifier -> int
+
+(* Identifiers sets and maps *)
+module Idset  : Set.S with type elt = identifier
+module Idpred : Predicate.S with type elt = identifier
+module Idmap  : Map.S with type key = identifier
+
+(*s Directory paths = section names paths *)
+type module_ident = identifier
+module ModIdmap : Map.S with type key = module_ident
+
+type dir_path
+
+(* Inner modules idents on top of list (to improve sharing).
+   For instance: A.B.C is ["C";"B";"A"] *)
+val make_dirpath : module_ident list -> dir_path
+val repr_dirpath : dir_path -> module_ident list
+
+val empty_dirpath : dir_path
+
+(* Printing of directory paths as ["coq_root.module.submodule"] *)
+val string_of_dirpath : dir_path -> string
+
+
+(*s Unique identifier to be used as "self" in structures and 
+  signatures - invisible for users *)
+  
+type mod_self_id
+
+(* The first argument is a file name - to prevent conflict between 
+   different files *)
+val make_msid : dir_path -> string -> mod_self_id
+val id_of_msid : mod_self_id -> identifier
+val debug_string_of_msid : mod_self_id -> string
+
+(*s Unique names for bound modules *)
+type mod_bound_id
+
+val make_mbid : dir_path -> string -> mod_bound_id
+val id_of_mbid : mod_bound_id -> identifier
+val debug_string_of_mbid : mod_bound_id -> string
+
+(*s Names of structure elements *)
+type label
+val mk_label : string -> label
+val string_of_label : label -> string
+
+val label_of_id : identifier -> label
+val id_of_label : label -> identifier
+
+module Labset : Set.S with type elt = label
+module Labmap : Map.S with type key = label
+
+(*s The module part of the kernel name *)
+type module_path =
+  | MPfile of dir_path
+  | MPbound of mod_bound_id
+  | MPself of mod_self_id 
+  | MPdot of module_path * label
+(*i  | MPapply of module_path * module_path    in the future (maybe) i*)
+
+
+val string_of_mp : module_path -> string
+
+module MPset : Set.S with type elt = module_path
+module MPmap : Map.S with type key = module_path
+
+
+(*s Substitutions *)
+
+type substitution
+
+val empty_subst : substitution
+
+val add_msid : 
+  mod_self_id -> module_path -> substitution -> substitution
+val add_mbid : 
+  mod_bound_id -> module_path -> substitution -> substitution
+
+val map_msid : mod_self_id -> module_path -> substitution
+val map_mbid : mod_bound_id -> module_path -> substitution
+
+(* sequential composition: 
+   [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
+*)
+val join : substitution -> substitution -> substitution
+
+(*i debugging *)
+val debug_string_of_subst : substitution -> string
+val debug_pr_subst : substitution -> Pp.std_ppcmds
+(*i*)
+
+(* [subst_mp sub mp] guarantees that whenever the result of the
+   substitution is structutally equal [mp], it is equal by pointers 
+   as well [==] *) 
+
+val subst_mp : 
+  substitution -> module_path -> module_path
+
+(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
+   on either side *)
+
+val occur_msid : mod_self_id -> substitution -> bool
+val occur_mbid : mod_bound_id -> substitution -> bool
+     
+
+(* Name of the toplevel structure *)
+val initial_msid : mod_self_id
+val initial_path : module_path (* [= MPself initial_msid] *)
+
+(* Initial "seed" of the unique identifier generator *)
+val initial_dir : dir_path
+
+(*s The absolute names of objects seen by kernel *)
+
+type kernel_name
+
+(* Constructor and destructor *)
+val make_kn : module_path -> dir_path -> label -> kernel_name
+val repr_kn : kernel_name -> module_path * dir_path * label
+
+val modpath : kernel_name -> module_path
+val label : kernel_name -> label
+
+val string_of_kn : kernel_name -> string
+val pr_kn : kernel_name -> Pp.std_ppcmds
+val subst_kn : substitution -> kernel_name -> kernel_name
+
+
+module KNset  : Set.S with type elt = kernel_name
+module KNpred : Predicate.S with type elt = kernel_name
+module KNmap  : Map.S with type key = kernel_name
+
+
+(*s Specific paths for declarations *)
+
+type variable = identifier
+type constant = kernel_name
+type mutual_inductive = kernel_name
+(* Beware: first inductive has index 0 *)
+type inductive = mutual_inductive * int
+(* Beware: first constructor has index 1 *)
+type constructor = inductive * int
+
+val ith_mutual_inductive : inductive -> int -> inductive
+val ith_constructor_of_inductive : inductive -> int -> constructor
+val inductive_of_constructor : constructor -> inductive
+val index_of_constructor : constructor -> int
+
+(* Better to have it here that in Closure, since required in grammar.cma *)
+type evaluable_global_reference =
+  | EvalVarRef of identifier
+  | EvalConstRef of constant
+
+(* Hash-consing *)
+val hcons_names : unit ->
+  (kernel_name -> kernel_name) * (dir_path -> dir_path) *
+  (name -> name) * (identifier -> identifier) * (string -> string)
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
new file mode 100644
index 00000000..5428a40d
--- /dev/null
+++ b/kernel/reduction.ml
@@ -0,0 +1,412 @@
+(************************************************************************)
+(*  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: reduction.ml,v 1.91.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Univ
+open Declarations
+open Environ
+open Closure
+open Esubst
+
+let rec is_empty_stack = function
+    [] -> true
+  | Zupdate _::s -> is_empty_stack s
+  | Zshift _::s -> is_empty_stack s
+  | _ -> false
+
+(* Compute the lift to be performed on a term placed in a given stack *)
+let el_stack el stk =
+  let n =
+    List.fold_left
+      (fun i z ->
+        match z with
+            Zshift n -> i+n
+          | _ -> i)
+      0
+      stk in
+  el_shft n el
+
+let compare_stack_shape stk1 stk2 =
+  let rec compare_rec bal stk1 stk2 =
+  match (stk1,stk2) with
+      ([],[]) -> bal=0
+    | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2
+    | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
+    | (Zapp l1::s1, _) -> compare_rec (bal+List.length l1) s1 stk2
+    | (_, Zapp l2::s2) -> compare_rec (bal-List.length l2) stk1 s2
+    | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) ->
+        bal=0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
+    | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
+        bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
+    | (_,_) -> false in
+  compare_rec 0 stk1 stk2
+
+let pure_stack lfts stk =
+  let rec pure_rec lfts stk =
+    match stk with
+        [] -> (lfts,[])
+      | zi::s ->
+          (match (zi,pure_rec lfts s) with
+              (Zupdate _,lpstk)  -> lpstk
+            | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
+            | (Zapp a1,(l,Zapp a2::pstk)) ->
+                (l,Zapp (List.map (fun t -> (l,t)) a1 @ a2)::pstk)
+            | (Zapp a, (l,pstk)) ->
+                (l,Zapp (List.map (fun t -> (l,t)) a)::pstk)
+            | (Zfix(fx,a),(l,pstk)) ->
+                let (lfx,pa) = pure_rec l a in
+                (l, Zfix((lfx,fx),pa)::pstk)
+            | (Zcase(ci,p,br),(l,pstk)) ->
+                (l,Zcase(ci,(l,p),Array.map (fun t -> (l,t)) br)::pstk)) in
+  snd (pure_rec lfts stk)
+
+(****************************************************************************)
+(*                   Reduction Functions                                    *)
+(****************************************************************************)
+
+let nf_betaiota t =
+  norm_val (create_clos_infos betaiota empty_env) (inject t)
+
+let whd_betaiotazeta env x =
+  match kind_of_term x with
+    | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> x
+    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
+
+let whd_betadeltaiota env t = 
+  match kind_of_term t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
+
+let whd_betadeltaiota_nolet env t = 
+  match kind_of_term t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t)
+
+(* Beta *)
+
+let beta_appvect c v =
+  let rec stacklam env t stack =
+    match (decomp_stack stack,kind_of_term t) with
+      | Some (h,stacktl), Lambda (_,_,c) -> stacklam (h::env) c stacktl
+      | _ -> app_stack (substl env t, stack) in
+  stacklam [] c (append_stack v empty_stack)
+
+(********************************************************************)
+(*                         Conversion                               *)
+(********************************************************************)
+
+(* Conversion utility functions *)
+type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+
+exception NotConvertible
+exception NotConvertibleVect of int
+
+let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
+  let rec cmp_rec pstk1 pstk2 cuniv =
+    match (pstk1,pstk2) with
+      | (z1::s1, z2::s2) ->
+          let c1 = cmp_rec s1 s2 cuniv in
+          (match (z1,z2) with
+            | (Zapp a1,Zapp a2) -> List.fold_right2 f a1 a2 c1
+            | (Zfix(fx1,a1),Zfix(fx2,a2)) ->
+                let c2 = f fx1 fx2 c1 in
+                cmp_rec a1 a2 c2
+            | (Zcase(ci1,p1,br1),Zcase(ci2,p2,br2)) ->
+                if not (fmind ci1.ci_ind ci2.ci_ind) then
+		  raise NotConvertible;
+		let c2 = f p1 p2 c1 in
+                array_fold_right2 f br1 br2 c2
+            | _ -> assert false)
+      | _ -> cuniv in
+  if compare_stack_shape stk1 stk2 then
+    cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv
+  else raise NotConvertible
+
+(* Convertibility of sorts *)
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+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 conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
+
+let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
+
+
+(* Conversion between  [lft1]term1 and [lft2]term2 *)
+let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = 
+  Util.check_for_interrupt ();
+  eqappr cv_pb infos
+    (lft1, whd_stack infos term1 [])
+    (lft2, whd_stack infos term2 [])
+    cuniv
+
+(* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
+and eqappr cv_pb infos appr1 appr2 cuniv =
+  let (lft1,(hd1,v1)) = appr1 in
+  let (lft2,(hd2,v2)) = appr2 in
+  let el1 = el_stack lft1 v1 in
+  let el2 = el_stack lft2 v2 in
+  match (fterm_of hd1, fterm_of hd2) with
+    (* case of leaves *)
+    | (FAtom a1, FAtom a2) ->
+	(match kind_of_term a1, kind_of_term a2 with
+	   | (Sort s1, Sort s2) -> 
+	       assert (is_empty_stack v1 && is_empty_stack v2);
+	       sort_cmp cv_pb s1 s2 cuniv
+	   | (Meta n, Meta m) ->
+               if n=m
+	       then convert_stacks infos lft1 lft2 v1 v2 cuniv
+               else raise NotConvertible
+	   | _ -> raise NotConvertible)
+    | (FEvar (ev1,args1), FEvar (ev2,args2)) ->
+        if ev1=ev2 then
+          let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in
+          convert_vect infos el1 el2 args1 args2 u1
+        else raise NotConvertible
+
+    (* 2 index known to be bound to no constant *)
+    | (FRel n, FRel m) ->
+        if reloc_rel n el1 = reloc_rel m el2
+        then convert_stacks infos lft1 lft2 v1 v2 cuniv
+        else raise NotConvertible
+
+    (* 2 constants, 2 local defined vars or 2 defined rels *)
+    | (FFlex fl1, FFlex fl2) ->
+	(try (* try first intensional equality *)
+	  if fl1 = fl2
+          then convert_stacks infos lft1 lft2 v1 v2 cuniv
+          else raise NotConvertible
+        with NotConvertible ->
+          (* else the oracle tells which constant is to be expanded *)
+          let (app1,app2) =
+            if Conv_oracle.oracle_order fl1 fl2 then
+              match unfold_reference infos fl1 with
+                | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+                | None ->
+                    (match unfold_reference infos fl2 with
+                      | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+		      | None -> raise NotConvertible)
+            else
+	      match unfold_reference infos fl2 with
+                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                | None ->
+                    (match unfold_reference infos fl1 with
+                    | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+		    | None -> raise NotConvertible) in
+          eqappr cv_pb infos app1 app2 cuniv)
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 -> 
+	       eqappr cv_pb infos (lft1, whd_stack infos def1 v1) appr2 cuniv
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 -> 
+	       eqappr cv_pb infos appr1 (lft2, whd_stack infos def2 v2) cuniv
+           | None -> raise NotConvertible)
+	
+    (* other constructors *)
+    | (FLambda _, FLambda _) ->
+        let (_,ty1,bd1) = destFLambda mk_clos hd1 in
+        let (_,ty2,bd2) = destFLambda mk_clos hd2 in
+        let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+
+    | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
+        assert (is_empty_stack v1 && is_empty_stack v2);
+	(* Luo's system *)
+        let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
+
+    (* Inductive types:  MutInd MutConstruct Fix Cofix *)
+
+     | (FInd (kn1,i1), FInd (kn2,i2)) ->
+         if i1 = i2 && mind_equiv infos kn1 kn2
+	 then
+           convert_stacks infos lft1 lft2 v1 v2 cuniv
+         else raise NotConvertible
+
+     | (FConstruct ((kn1,i1),j1), FConstruct ((kn2,i2),j2)) ->
+	 if i1 = i2 && j1 = j2 && mind_equiv infos kn1 kn2
+	 then
+           convert_stacks infos lft1 lft2 v1 v2 cuniv
+         else raise NotConvertible
+
+     | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
+	 if op1 = op2
+	 then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+	   let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
+           let u2 =
+             convert_vect infos 
+		 (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+           convert_stacks infos lft1 lft2 v1 v2 u2
+         else raise NotConvertible
+
+     | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
+         if op1 = op2
+         then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+           let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
+           let u2 =
+	     convert_vect infos
+		 (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+           convert_stacks infos lft1 lft2 v1 v2 u2
+         else raise NotConvertible
+
+    | ( (FLetIn _, _) | (_, FLetIn _) | (FCases _,_) | (_,FCases _)
+      | (FApp _,_) | (_,FApp _) | (FCLOS _, _) | (_,FCLOS _)
+      | (FLIFT _, _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED)) ->
+        anomaly "Unexpected term returned by fhnf"
+
+     | _ -> raise NotConvertible
+
+and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
+  compare_stacks
+    (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
+    (fun (mind1,i1) (mind2,i2) -> i1=i2 && mind_equiv infos mind1 mind2)
+    lft1 stk1 lft2 stk2 cuniv
+
+and convert_vect infos lft1 lft2 v1 v2 cuniv =
+  let lv1 = Array.length v1 in
+  let lv2 = Array.length v2 in
+  if lv1 = lv2
+  then 
+    let rec fold n univ = 
+      if n >= lv1 then univ
+      else
+        let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
+        fold (n+1) u1 in
+    fold 0 cuniv
+  else raise NotConvertible
+
+
+
+let fconv cv_pb env t1 t2 =
+  if eq_constr t1 t2 then 
+    Constraint.empty
+  else
+    let infos = create_clos_infos betaiotazeta env in
+    ccnv cv_pb infos ELID ELID (inject t1) (inject t2)
+      Constraint.empty
+
+let conv = fconv CONV
+let conv_leq = fconv CUMUL
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i c t1 t2 ->
+      let c' =
+        try conv_leq env t1 t2 
+        with NotConvertible -> raise (NotConvertibleVect i) in
+      Constraint.union c c')
+    Constraint.empty
+    v1
+    v2
+
+(*
+let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";;
+let conv_leq env t1 t2 =
+  Profile.profile4 convleqkey conv_leq env t1 t2;;
+
+let convkey = Profile.declare_profile "Kernel_reduction.conv";;
+let conv env t1 t2 =
+  Profile.profile4 convleqkey conv env t1 t2;;
+*)
+
+(********************************************************************)
+(*             Special-Purpose Reduction                            *)
+(********************************************************************)
+
+(* 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 t n =
+  match kind_of_term (whd_betadeltaiota env t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_prod_app: Need a product"
+
+let hnf_prod_applist env t nl = 
+  List.fold_left (hnf_prod_app env) t nl
+
+(* Dealing with arities *)
+
+let dest_prod env = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env c in
+    match kind_of_term t with
+      | Prod (n,a,c0) ->
+          let d = (n,None,a) in
+	  decrec (push_rel d env) (Sign.add_rel_decl d m) c0
+      | _ -> m,t
+  in 
+  decrec env Sign.empty_rel_context
+
+(* The same but preserving lets *)
+let dest_prod_assum env = 
+  let rec prodec_rec env l ty =
+    let rty = whd_betadeltaiota_nolet env ty in
+    match kind_of_term rty with
+    | Prod (x,t,c)  ->
+        let d = (x,None,t) in
+	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
+    | LetIn (x,b,t,c) ->
+        let d = (x,Some b,t) in
+	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
+    | Cast (c,_)    -> prodec_rec env l c
+    | _               -> l,rty
+  in
+  prodec_rec env Sign.empty_rel_context
+
+let dest_arity env c =
+  let l, c = dest_prod env c in
+  match kind_of_term c with
+    | Sort s -> l,s
+    | _ -> error "not an arity"
+
+let is_arity env c =
+  try
+    let _ = dest_arity env c in
+    true
+  with UserError _ -> false
+
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
new file mode 100644
index 00000000..c516ea70
--- /dev/null
+++ b/kernel/reduction.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: reduction.mli,v 1.56.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Environ
+(*i*)
+
+(************************************************************************)
+(*s Reduction functions *)
+
+val whd_betaiotazeta        : env -> constr -> constr
+val whd_betadeltaiota       : env -> constr -> constr
+val whd_betadeltaiota_nolet : env -> constr -> constr
+
+val nf_betaiota      : constr -> constr
+
+(************************************************************************)
+(*s conversion functions *)
+
+exception NotConvertible
+exception NotConvertibleVect of int
+type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+
+val conv_sort      : sorts conversion_function
+val conv_sort_leq  : sorts conversion_function
+
+val conv           : types conversion_function
+val conv_leq       : types conversion_function
+val conv_leq_vecti : types array conversion_function
+
+(************************************************************************)
+
+(* Builds an application node, reducing beta redexes it may produce. *) 
+val beta_appvect : constr -> constr array -> constr
+
+(* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
+val hnf_prod_applist : env -> types -> constr list -> types
+
+
+(************************************************************************)
+(*s Recognizing products and arities modulo reduction *)
+
+val dest_prod       : env -> types -> Sign.rel_context * types
+val dest_prod_assum : env -> types -> Sign.rel_context * types
+
+val dest_arity : env -> types -> Sign.arity
+val is_arity   : env -> types -> bool
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
new file mode 100644
index 00000000..4f180599
--- /dev/null
+++ b/kernel/safe_typing.ml
@@ -0,0 +1,572 @@
+(************************************************************************)
+(*  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: safe_typing.ml,v 1.76.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Sign
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Typeops
+open Type_errors
+open Indtypes
+open Term_typing
+open Modops
+open Subtyping
+open Mod_typing
+
+type modvariant = 
+  | NONE 
+  | SIG of (* funsig params *) (mod_bound_id * module_type_body) list 
+  | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list
+      * (* optional result type *) module_type_body option
+  | LIBRARY of dir_path
+
+type module_info = 
+    { msid : mod_self_id;
+      modpath : module_path;
+      seed : dir_path; (* the "seed" of unique identifier generator *)
+      label : label;
+      variant : modvariant}
+
+let check_label l labset = 
+  if Labset.mem l labset then error_existing_label l
+
+type library_info = dir_path * Digest.t
+
+type safe_environment = 
+    { old : safe_environment;
+      env : env;
+      modinfo : module_info;
+      labset : Labset.t;
+      revsign : module_signature_body;
+      revstruct : module_structure_body;
+      imports : library_info list;
+      loads : (module_path * module_body) list }
+
+(*
+  { old = senv.old;
+    env = ;
+    modinfo = senv.modinfo;
+    labset = ;
+    revsign = ;
+    imports = senv.imports ;
+    loads = senv.loads }
+*)
+
+
+(* a small hack to avoid variants and an unused case in all functions *)
+let rec empty_environment = 
+  { old = empty_environment; 
+    env = empty_env;
+    modinfo = {
+      msid = initial_msid;
+      modpath = initial_path;
+      seed = initial_dir;
+      label = mk_label "_";
+      variant = NONE};
+    labset = Labset.empty;
+    revsign = [];
+    revstruct = [];
+    imports = [];
+    loads = [] }
+
+let env_of_safe_env senv = senv.env
+let env_of_senv = env_of_safe_env
+
+
+(* Insertion of section variables. They are now typed before being
+   added to the environment. *)
+
+(* Same as push_named, but check that the variable is not already
+   there. Should *not* be done in Environ because tactics add temporary
+   hypothesis many many times, and the check performed here would
+   cost too much. *)
+let safe_push_named (id,_,_ as d) env =
+  let _ =
+    try
+      let _ = lookup_named id env in 
+      error ("identifier "^string_of_id id^" already defined")
+    with Not_found -> () in
+  Environ.push_named d env
+
+let push_named_def (id,b,topt) senv =
+  let (c,typ,cst) = translate_local_def senv.env (b,topt) in
+  let env' = add_constraints cst senv.env in
+  let env'' = safe_push_named (id,Some c,typ) env' in
+  (cst, {senv with env=env''})
+
+let push_named_assum (id,t) senv =
+  let (t,cst) = translate_local_assum senv.env t in
+  let env' = add_constraints cst senv.env in
+  let env'' = safe_push_named (id,None,t) env' in
+  (cst, {senv with env=env''})
+
+
+(* Insertion of constants and parameters in environment. *)
+
+type global_declaration = 
+  | ConstantEntry of constant_entry
+  | GlobalRecipe of Cooking.recipe
+
+let hcons_constant_body cb =
+  let body = match cb.const_body with
+      None -> None
+    | Some l_constr -> let constr = Declarations.force l_constr in
+	Some (Declarations.from_val (hcons1_constr constr))
+  in
+    { cb with
+	const_body = body;
+	const_type = hcons1_constr cb.const_type }
+
+let add_constant dir l decl senv =
+  check_label l senv.labset;
+  let cb = match decl with 
+      ConstantEntry ce -> translate_constant senv.env ce
+    | GlobalRecipe r ->
+        let cb = translate_recipe senv.env r in
+        if dir = empty_dirpath then hcons_constant_body cb else cb
+  in
+(*  let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*)
+  let env' = Environ.add_constraints cb.const_constraints senv.env in
+  let kn = make_kn senv.modinfo.modpath dir l in
+  let env'' = Environ.add_constant kn cb env' in
+  kn, { old = senv.old;
+	env = env'';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;
+	revsign = (l,SPBconst cb)::senv.revsign;
+	revstruct = (l,SEBconst cb)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+    
+
+(* Insertion of inductive types. *)
+
+let add_mind dir l mie senv =
+  if mie.mind_entry_inds = [] then 
+    anomaly "empty inductive types declaration"; 
+            (* this test is repeated by translate_mind *)
+  let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in
+  if l <> label_of_id id then
+    anomaly ("the label of inductive packet and its first inductive"^
+	     " type do not match");
+  check_label l senv.labset; 
+    (* TODO: when we will allow reorderings we will have to verify 
+       all labels *)
+  let mib = translate_mind senv.env mie in
+  let env' = Environ.add_constraints mib.mind_constraints senv.env in
+  let kn = make_kn senv.modinfo.modpath dir l in
+  let env'' = Environ.add_mind kn mib env' in
+  kn, { old = senv.old;
+	env = env'';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;  (* TODO: the same as above *)
+	revsign = (l,SPBmind mib)::senv.revsign;
+	revstruct = (l,SEBmind mib)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+(* Insertion of module types *)
+
+let add_modtype l mte senv = 
+  check_label l senv.labset; 
+  let mtb = translate_modtype senv.env mte in
+  let env' = add_modtype_constraints senv.env mtb in
+  let kn = make_kn senv.modinfo.modpath empty_dirpath l in
+  let env'' = Environ.add_modtype kn mtb env' in
+  kn, { old = senv.old;
+	env = env'';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;
+	revsign = (l,SPBmodtype mtb)::senv.revsign;
+	revstruct = (l,SEBmodtype mtb)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+
+(* full_add_module adds module with universes and constraints *)
+let full_add_module mp mb env =
+  let env = add_module_constraints env mb in
+  let env = Modops.add_module mp mb env in
+    env
+
+(* Insertion of modules *)
+
+let add_module l me senv = 
+  check_label l senv.labset; 
+  let mb = translate_module senv.env me in
+  let mspec = module_spec_of_body mb in
+  let mp = MPdot(senv.modinfo.modpath, l) in
+  let env' = full_add_module mp mb senv.env in
+  mp, { old = senv.old;
+	env = env';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;
+	revsign = (l,SPBmodule mspec)::senv.revsign;
+	revstruct = (l,SEBmodule mb)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+(* Interactive modules *)
+
+let start_module l params result senv = 
+  check_label l senv.labset; 
+  let rec trans_params env = function 
+    | [] -> env,[] 
+    | (mbid,mte)::rest -> 
+	let mtb = translate_modtype env mte in
+	let env = 
+	  full_add_module (MPbound mbid) (module_body_of_type mtb) env 
+	in
+	let env,transrest = trans_params env rest in
+	env, (mbid,mtb)::transrest
+  in
+  let env,params_body = trans_params senv.env params in
+  let check_sig mtb = match scrape_modtype env mtb with
+    | MTBsig _ -> ()
+    | MTBfunsig _ -> error_result_must_be_signature mtb 
+    | _ -> anomaly "start_module: modtype not scraped"
+  in
+  let result_body = option_app (translate_modtype env) result in
+  ignore (option_app check_sig result_body);
+  let msid = make_msid senv.modinfo.seed (string_of_label l) in
+  let mp = MPself msid in
+  let modinfo = { msid = msid;
+		  modpath = mp;
+		  seed = senv.modinfo.seed;
+		  label = l;
+		  variant = STRUCT(params_body,result_body) }
+  in
+  mp, { old = senv;
+	env = env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+
+
+let end_module l senv = 
+  let oldsenv = senv.old in
+  let modinfo = senv.modinfo in
+  let params, restype = 
+    match modinfo.variant with
+      | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
+      | STRUCT(params,restype) -> (params,restype)
+  in
+  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
+  if not (empty_context senv.env) then error_local_context None;
+  let functorize_type = 
+    List.fold_right 
+      (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb))
+      params
+  in
+  let auto_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
+  let mtb, mod_user_type, cst = 
+    match restype with
+      | None -> functorize_type auto_tb, None, Constraint.empty
+      | Some res_tb -> 
+	  let cst = check_subtypes senv.env auto_tb res_tb in
+	  let mtb = functorize_type res_tb in
+	    mtb, Some mtb, cst
+  in
+  let mexpr = 
+    List.fold_right
+      (fun (arg_id,arg_b) mtb -> MEBfunctor (arg_id,arg_b,mtb))
+      params
+      (MEBstruct (modinfo.msid, List.rev senv.revstruct)) 
+  in
+  let mb = 
+    { mod_expr = Some mexpr;
+      mod_user_type = mod_user_type;
+      mod_type = mtb;
+      mod_equiv = None;
+      mod_constraints = cst }
+  in
+  let mspec = 
+    { msb_modtype = mtb;
+      msb_equiv = None;
+      msb_constraints = Constraint.empty } 
+  in
+  let mp = MPdot (oldsenv.modinfo.modpath, l) in
+  let newenv = oldsenv.env in
+  let newenv = 
+    List.fold_left
+      (fun env (mp,mb) -> full_add_module mp mb env) 
+      newenv
+      senv.loads
+  in
+  let newenv = 
+    full_add_module mp mb newenv
+  in 
+  mp, { old = oldsenv.old;
+	env = newenv;
+	modinfo = oldsenv.modinfo;
+	labset = Labset.add l oldsenv.labset;
+	revsign = (l,SPBmodule mspec)::oldsenv.revsign;
+	revstruct = (l,SEBmodule mb)::oldsenv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads@oldsenv.loads }
+
+
+(* Interactive module types *)
+
+let start_modtype l params senv = 
+  check_label l senv.labset; 
+  let rec trans_params env = function 
+    | [] -> env,[] 
+    | (mbid,mte)::rest -> 
+	let mtb = translate_modtype env mte in
+	let env = 
+	  full_add_module (MPbound mbid) (module_body_of_type mtb) env 
+	in
+	let env,transrest = trans_params env rest in
+	env, (mbid,mtb)::transrest
+  in
+  let env,params_body = trans_params senv.env params in
+  let msid = make_msid senv.modinfo.seed (string_of_label l) in
+  let mp = MPself msid in
+  let modinfo = { msid = msid;
+		  modpath = mp;
+		  seed = senv.modinfo.seed;
+		  label = l;
+		  variant = SIG params_body }
+  in
+  mp, { old = senv;
+	env = env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+let end_modtype l senv = 
+  let oldsenv = senv.old in
+  let modinfo = senv.modinfo in
+  let params = 
+    match modinfo.variant with
+      | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end ()
+      | SIG params -> params
+  in
+  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
+  if not (empty_context senv.env) then error_local_context None;
+  let res_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
+  let mtb = 
+    List.fold_right 
+      (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb))
+      params
+      res_tb
+  in
+  let kn = make_kn oldsenv.modinfo.modpath empty_dirpath l in
+  let newenv = oldsenv.env in
+  let newenv = 
+    List.fold_left
+      (fun env (mp,mb) -> full_add_module mp mb env) 
+      newenv
+      senv.loads
+  in
+  let newenv = 
+    add_modtype_constraints newenv mtb 
+  in
+  let newenv = 
+    Environ.add_modtype kn mtb newenv
+  in 
+  kn, { old = oldsenv.old;
+	env = newenv;
+	modinfo = oldsenv.modinfo;
+	labset = Labset.add l oldsenv.labset;
+	revsign = (l,SPBmodtype mtb)::oldsenv.revsign;
+	revstruct = (l,SEBmodtype mtb)::oldsenv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads@oldsenv.loads }
+  
+
+let current_modpath senv = senv.modinfo.modpath
+let current_msid senv = senv.modinfo.msid
+
+
+let add_constraints cst senv = 
+  {senv with env = Environ.add_constraints cst senv.env}
+
+(* Check that the engagement expected by a library matches the initial one *)
+let check_engagement env c =
+  match Environ.engagement env, c with
+    | Some ImpredicativeSet, Some ImpredicativeSet -> ()
+    | _, None -> ()
+    | _, Some ImpredicativeSet ->
+        error "Needs option -impredicative-set"
+
+let set_engagement c senv =
+  {senv with env = Environ.set_engagement c senv.env}
+
+
+(* Libraries = Compiled modules *)
+
+type compiled_library = 
+    dir_path * module_body * library_info list * engagement option
+
+
+(* We check that only initial state Require's were performed before 
+   [start_library] was called *)
+
+let start_library dir senv =
+  if not (senv.revsign = [] &&
+	  senv.modinfo.msid = initial_msid &&
+	  senv.modinfo.variant = NONE)
+  then
+    anomaly "Safe_typing.start_library: environment should be empty";
+  let dir_path,l = 
+    match (repr_dirpath dir) with
+	[] -> anomaly "Empty dirpath in Safe_typing.start_library"
+      | hd::tl ->
+	  make_dirpath tl, label_of_id hd
+  in
+  let msid = make_msid dir_path (string_of_label l) in
+  let mp = MPself msid in
+  let modinfo = { msid = msid;
+		  modpath = mp;
+		  seed = dir;
+		  label = l;
+		  variant = LIBRARY dir }
+  in
+  mp, { old = senv;
+	env = senv.env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+
+let export senv dir = 
+  let modinfo = senv.modinfo in
+  begin
+    match modinfo.variant with
+      | LIBRARY dp -> 
+	  if dir <> dp then
+	    anomaly "We are not exporting the right library!"
+      | _ ->
+	  anomaly "We are not exporting the library"
+  end;
+  (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
+    (* error_export_simple *) (); *)
+  let mb = 
+    { mod_expr = Some (MEBstruct (modinfo.msid, List.rev senv.revstruct));
+      mod_type = MTBsig (modinfo.msid, List.rev senv.revsign);
+      mod_user_type = None;
+      mod_equiv = None;
+      mod_constraints = Constraint.empty }
+  in
+    modinfo.msid, (dir,mb,senv.imports,engagement senv.env)
+
+
+let check_imports senv needed =
+  let imports = senv.imports in
+  let check (id,stamp) =
+    try
+      let actual_stamp = List.assoc id imports in
+      if stamp <> actual_stamp then
+	error ("Inconsistent assumptions over module " ^(string_of_dirpath id))
+    with Not_found -> 
+      error ("Reference to unknown module " ^ (string_of_dirpath id))
+  in
+  List.iter check needed
+
+(* we have an inefficiency: Since loaded files are added to the
+environment every time a module is closed, their components are
+calculated many times. Thic could be avoided in several ways:
+
+1 - for each file create a dummy environment containing only this
+file's components, merge this environment with the global
+environment, and store for the future (instead of just its type)
+
+2 - create "persistent modules" environment table in Environ add put
+loaded by side-effect once and for all (like it is done in OCaml).
+Would this be correct with respect to undo's and stuff ?
+*)
+ 
+let import (dp,mb,depends,engmt) digest senv = 
+  check_imports senv depends;
+  check_engagement senv.env engmt;
+  let mp = MPfile dp in
+  let env = senv.env in
+  mp, { senv with 
+	  env = full_add_module mp mb env; 
+	  imports = (dp,digest)::senv.imports;
+	  loads = (mp,mb)::senv.loads }
+
+
+(** Remove the body of opaque constants in modules *)
+ 
+let rec lighten_module mb =
+  { mb with
+    mod_expr = option_app lighten_modexpr mb.mod_expr;
+    mod_type = lighten_modtype mb.mod_type;
+    mod_user_type = option_app lighten_modtype mb.mod_user_type }
+
+and lighten_modtype = function
+  | MTBident kn as x -> x
+  | MTBfunsig (mbid,mtb1,mtb2) ->
+      MTBfunsig (mbid, lighten_modtype mtb1, lighten_modtype mtb2)
+  | MTBsig (msid,sign) -> MTBsig (msid, lighten_sig sign)
+
+and lighten_modspec ms =
+  { ms with msb_modtype = lighten_modtype ms.msb_modtype }
+
+and lighten_sig sign = 
+  let lighten_spec (l,spec) = (l,match spec with
+    | SPBconst ({const_opaque=true} as x) -> SPBconst {x with const_body=None}
+    | (SPBconst _ | SPBmind _) as x -> x
+    | SPBmodule m -> SPBmodule (lighten_modspec m)
+    | SPBmodtype m -> SPBmodtype (lighten_modtype m))
+  in
+    List.map lighten_spec sign
+
+and lighten_struct struc = 
+  let lighten_body (l,body) = (l,match body with
+    | SEBconst ({const_opaque=true} as x) -> SEBconst {x with const_body=None}
+    | (SEBconst _ | SEBmind _) as x -> x
+    | SEBmodule m -> SEBmodule (lighten_module m)
+    | SEBmodtype m -> SEBmodtype (lighten_modtype m))
+  in
+    List.map lighten_body struc
+
+and lighten_modexpr = function
+  | MEBfunctor (mbid,mty,mexpr) ->
+      MEBfunctor (mbid,lighten_modtype mty,lighten_modexpr mexpr)
+  | MEBident mp as x -> x
+  | MEBstruct (msid, struc) ->
+      MEBstruct (msid, lighten_struct struc)
+  | MEBapply (mexpr,marg,u) ->
+      MEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
+
+let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
+
+
+type judgment = unsafe_judgment
+
+let j_val j = j.uj_val
+let j_type j = j.uj_type
+
+let safe_infer senv = infer (env_of_senv senv)
+    
+let typing senv = Typeops.typing (env_of_senv senv)
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
new file mode 100644
index 00000000..84b98984
--- /dev/null
+++ b/kernel/safe_typing.mli
@@ -0,0 +1,127 @@
+(************************************************************************)
+(*  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: safe_typing.mli,v 1.33.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Entries
+(*i*)
+
+(*s Safe environments. Since we are now able to type terms, we can
+  define an abstract type of safe environments, where objects are
+  typed before being added.
+
+  We also add [open_structure] and [close_section], [close_module] to
+  provide functionnality for sections and interactive modules 
+*)
+
+type safe_environment
+
+val env_of_safe_env : safe_environment -> Environ.env
+
+val empty_environment : safe_environment
+
+(* Adding and removing local declarations (Local or Variables) *)
+val push_named_assum :
+  identifier * types -> safe_environment ->
+    Univ.constraints * safe_environment
+val push_named_def :
+  identifier * constr * types option -> safe_environment ->
+    Univ.constraints * safe_environment
+
+(* Adding global axioms or definitions *)
+type global_declaration = 
+  | ConstantEntry of constant_entry
+  | GlobalRecipe of Cooking.recipe
+
+val add_constant : 
+  dir_path -> label -> global_declaration -> safe_environment -> 
+      kernel_name * safe_environment
+
+(* Adding an inductive type *)
+val add_mind : 
+  dir_path -> label -> mutual_inductive_entry -> safe_environment ->
+    mutual_inductive * safe_environment
+
+(* Adding a module *)
+val add_module :
+  label -> module_entry -> safe_environment 
+    -> module_path * safe_environment
+
+(* Adding a module type *)
+val add_modtype :
+  label -> module_type_entry -> safe_environment 
+    -> kernel_name * safe_environment
+
+(* Adding universe constraints *)
+val add_constraints : 
+  Univ.constraints -> safe_environment -> safe_environment
+
+(* Settin the strongly constructive or classical logical engagement *)
+val set_engagement : Environ.engagement -> safe_environment -> safe_environment
+
+
+(*s Interactive module functions *)
+val start_module : 
+  label -> (mod_bound_id * module_type_entry) list 
+    -> module_type_entry option 
+      -> safe_environment -> module_path * safe_environment
+
+val end_module :
+  label -> safe_environment -> module_path * safe_environment 
+
+
+val start_modtype :
+  label -> (mod_bound_id * module_type_entry) list
+    -> safe_environment -> module_path * safe_environment
+
+val end_modtype :
+  label -> safe_environment -> kernel_name * safe_environment
+
+
+val current_modpath : safe_environment -> module_path
+val current_msid : safe_environment -> mod_self_id
+
+
+(* Loading and saving compilation units *)
+
+(* exporting and importing modules *)
+type compiled_library
+
+val start_library : dir_path -> safe_environment 
+      -> module_path * safe_environment
+
+val export : safe_environment -> dir_path  
+      -> mod_self_id * compiled_library
+
+val import : compiled_library -> Digest.t -> safe_environment 
+      -> module_path * safe_environment
+
+(* Remove the body of opaque constants *)
+
+val lighten_library : compiled_library -> compiled_library
+
+(*s Typing judgments *)
+
+type judgment
+
+val j_val : judgment -> constr
+val j_type : judgment -> constr
+
+(* Safe typing of a term returning a typing judgment and universe
+   constraints to be added to the environment for the judgment to
+   hold. It is guaranteed that the constraints are satisfiable
+ *)
+val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
+
+val typing : safe_environment -> constr -> judgment
+
+
diff --git a/kernel/sign.ml b/kernel/sign.ml
new file mode 100644
index 00000000..a4b2a2ea
--- /dev/null
+++ b/kernel/sign.ml
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  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: sign.ml,v 1.37.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Names
+open Util
+open Term
+
+(*s Signatures of named hypotheses. Used for section variables and
+    goal assumptions. *)
+
+type named_context = named_declaration list
+
+let empty_named_context = []
+
+let add_named_decl d sign = d::sign
+
+let rec lookup_named id = function
+  | (id',_,_ as decl) :: _ when id=id' -> decl
+  | _ :: sign -> lookup_named id sign
+  | [] -> raise Not_found
+
+let named_context_length = List.length
+
+let vars_of_named_context = List.map (fun (id,_,_) -> id)
+
+let instance_from_named_context sign =
+  let rec inst_rec = function
+    | (id,None,_) :: sign -> mkVar id :: inst_rec sign
+    | _ :: sign -> inst_rec sign
+    | [] -> [] in
+  Array.of_list (inst_rec sign)
+
+let fold_named_context f l ~init = List.fold_right f l init
+let fold_named_context_reverse f ~init l = List.fold_left f init l
+
+(*s Signatures of ordered section variables *)
+type section_context = named_context
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices (to represent bound variables) *)
+
+type rel_declaration = name * constr option * types
+type rel_context = rel_declaration list
+
+let empty_rel_context = []
+
+let add_rel_decl d ctxt = d::ctxt
+
+let lookup_rel n sign =
+  let rec lookrec = function
+    | (1, decl :: _) -> decl
+    | (n, _ :: sign) -> lookrec (n-1,sign)
+    | (_, [])        -> raise Not_found
+  in 
+  lookrec (n,sign)
+
+let rel_context_length = List.length
+
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 hyps
+
+let fold_rel_context f l ~init:x = List.fold_right f l x
+let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
+
+let map_rel_context f l = 
+  let map_decl (n, body_o, typ as decl) =
+    let body_o' = option_smartmap f body_o in
+    let typ' = f typ in
+      if body_o' == body_o && typ' == typ then decl else
+	(n, body_o', typ')
+  in
+    list_smartmap map_decl l
+
+(* Push named declarations on top of a rel context *)
+(* Bizarre. Should be avoided. *)
+let push_named_to_rel_context hyps ctxt =
+  let rec push = function
+    | (id,b,t) :: l ->
+	let s, hyps = push l in
+	let d = (Name id, option_app (subst_vars s) b, type_app (subst_vars s) t) in
+	id::s, d::hyps
+    | [] -> [],[] in
+  let s, hyps = push hyps in
+  let rec subst = function
+    | d :: l ->
+	let n, ctxt = subst l in
+	(n+1), (map_rel_declaration (substn_vars n s) d)::ctxt
+    | [] -> 1, hyps in
+  snd (subst ctxt)
+
+
+(*********************************)
+(*       Term constructors       *)
+(*********************************)
+
+let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
+let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
+
+(*********************************)
+(*       Term destructors        *)
+(*********************************)
+
+type arity = rel_context * sorts
+
+(* Decompose an arity (i.e. a product of the form (x1:T1)..(xn:Tn)s
+   with s a sort) into the pair ([(xn,Tn);...;(x1,T1)],s) *)
+
+let destArity = 
+  let rec prodec_rec l c =
+    match kind_of_term c with
+    | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
+    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
+    | Cast (c,_)      -> prodec_rec l c
+    | Sort s          -> l,s
+    | _               -> anomaly "destArity: not an arity"
+  in 
+  prodec_rec []
+
+let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign
+
+let rec isArity c =
+  match kind_of_term c with
+  | Prod (_,_,c)    -> isArity c
+  | LetIn (_,b,_,c) -> isArity (subst1 b c)
+  | Cast (c,_)      -> isArity c
+  | Sort _          -> true
+  | _               -> false
+
+(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
+let decompose_prod_assum = 
+  let rec prodec_rec l c =
+    match kind_of_term c with
+    | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) c
+    | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c
+    | Cast (c,_)      -> prodec_rec l c
+    | _               -> l,c
+  in 
+  prodec_rec empty_rel_context
+
+(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
+let decompose_lam_assum = 
+  let rec lamdec_rec l c =
+    match kind_of_term c with
+    | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
+    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
+    | Cast (c,_)      -> lamdec_rec l c
+    | _               -> l,c
+  in 
+  lamdec_rec empty_rel_context
+
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_prod_n_assum n =
+  if n < 0 then
+    error "decompose_prod_n_assum: integer parameter must be positive";
+  let rec prodec_rec l n c = 
+    if n=0 then l,c
+    else match kind_of_term c with 
+    | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c
+    | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
+    | Cast (c,_)      -> prodec_rec l n c
+    | c -> error "decompose_prod_n_assum: not enough assumptions"
+  in 
+  prodec_rec empty_rel_context n
+
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_lam_n_assum n =
+  if n < 0 then
+    error "decompose_lam_n_assum: integer parameter must be positive";
+  let rec lamdec_rec l n c = 
+    if n=0 then l,c 
+    else match kind_of_term c with 
+    | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
+    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
+    | Cast (c,_)      -> lamdec_rec l n c
+    | c -> error "decompose_lam_n_assum: not enough abstractions"
+  in 
+  lamdec_rec empty_rel_context n 
diff --git a/kernel/sign.mli b/kernel/sign.mli
new file mode 100644
index 00000000..3f0549cc
--- /dev/null
+++ b/kernel/sign.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  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: sign.mli,v 1.40.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+(*i*)
+
+(*s Signatures of ordered named declarations *)
+
+type named_context = named_declaration list
+type section_context = named_context
+
+val empty_named_context : named_context
+val add_named_decl : named_declaration -> named_context -> named_context
+val vars_of_named_context : named_context -> identifier list
+
+val lookup_named : identifier -> named_context -> named_declaration
+
+(* number of declarations *)
+val named_context_length : named_context -> int
+
+(*s Recurrence on [named_context]: older declarations processed first *)
+val fold_named_context :
+  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
+(* newer declarations first *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
+
+(*s Section-related auxiliary functions *)
+val instance_from_named_context : named_context -> constr array
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices *)
+
+(* In [rel_context], more recent declaration is on top *)
+type rel_context = rel_declaration list
+
+val empty_rel_context : rel_context
+val add_rel_decl : rel_declaration -> rel_context -> rel_context
+
+val lookup_rel : int -> rel_context -> rel_declaration
+val rel_context_length : rel_context -> int
+val rel_context_nhyps : rel_context -> int
+
+val push_named_to_rel_context : named_context -> rel_context -> rel_context
+
+(*s Recurrence on [rel_context]: older declarations processed first *)
+val fold_rel_context :
+  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
+(* newer declarations first *)
+val fold_rel_context_reverse :
+  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
+
+(*s Map function of [rel_context] *)
+val map_rel_context : (constr -> constr) -> rel_context -> rel_context
+
+(*s Term constructors *)
+
+val it_mkLambda_or_LetIn : constr -> rel_context -> constr
+val it_mkProd_or_LetIn : types -> rel_context -> types
+
+(*s Term destructors *)
+
+(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *)
+type arity = rel_context * sorts
+val destArity : types -> arity
+val mkArity : arity -> types
+val isArity : types -> bool
+
+(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ including letins
+   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
+   product nor a let. *)
+val decompose_prod_assum : types -> rel_context * types
+
+(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ including letins
+   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
+   lambda nor a let. *)
+val decompose_lam_assum : constr -> rel_context * constr
+
+(* Given a positive integer n, transforms a product term 
+   $(x_1:T_1)..(x_n:T_n)T$
+   into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
+val decompose_prod_n_assum : int -> types -> rel_context * types
+
+(* Given a positive integer $n$, transforms a lambda term 
+   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+val decompose_lam_n_assum : int -> constr -> rel_context * constr
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
new file mode 100644
index 00000000..825ae8fa
--- /dev/null
+++ b/kernel/subtyping.ml
@@ -0,0 +1,246 @@
+(************************************************************************)
+(*  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: subtyping.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Reduction
+open Inductive
+open Modops
+(*i*)
+
+(* This local type is used to subtype a constant with a constructor or
+   an inductive type. It can also be useful to allow reorderings in
+   inductive types *)
+
+type namedobject = 
+  | Constant of constant_body
+  | Mind of mutual_inductive_body
+  | IndType of inductive * mutual_inductive_body
+  | IndConstr of constructor * mutual_inductive_body
+  | Module of module_specification_body
+  | Modtype of module_type_body
+
+(* adds above information about one mutual inductive: all types and
+   constructors *)
+
+let add_nameobjects_of_mib ln mib map = 
+  let add_nameobjects_of_one j oib map =
+    let ip = (ln,j) in
+    let map = 
+      array_fold_right_i 
+	(fun i id map -> Idmap.add id (IndConstr ((ip,i), mib)) map)
+	oib.mind_consnames
+	map
+    in
+      Idmap.add oib.mind_typename (IndType (ip, mib)) map
+  in
+    array_fold_right_i add_nameobjects_of_one mib.mind_packets map
+
+(* creates namedobject map for the whole signature *)
+
+let make_label_map msid list = 
+  let add_one (l,e) map = 
+    let obj = 
+      match e with
+	| SPBconst cb -> Constant cb
+	| SPBmind mib -> Mind mib
+	| SPBmodule mb -> Module mb
+	| SPBmodtype mtb -> Modtype mtb
+    in
+(*    let map = match obj with
+      | Mind mib -> 
+	  add_nameobjects_of_mib (make_ln (MPself msid) l) mib map
+      | _ -> map
+    in *)
+      Labmap.add l obj map
+  in
+    List.fold_right add_one list Labmap.empty
+
+let check_conv_error error cst f env a1 a2 =
+  try
+    Constraint.union cst (f env a1 a2)
+  with
+      NotConvertible -> error ()
+
+(* for now we do not allow reorderings *)
+let check_inductive cst env msid1 l info1 mib2 spec2 = 
+  let kn = make_kn (MPself msid1) empty_dirpath l in
+  let error () = error_not_match l spec2 in
+  let check_conv cst f = check_conv_error error cst f in
+  let mib1 = 
+    match info1 with
+      | Mind mib -> mib
+    (*  | IndType (_,mib) -> mib   we will enable this later*)
+      | _ -> error ()
+  in
+  let check_packet cst p1 p2 =
+    let check f = if f p1 <> f p2 then error () in
+      check (fun p -> p.mind_consnames);
+      check (fun p -> p.mind_typename);
+      (* nf_lc later *)
+      (* nf_arity later *)
+      (* user_lc ignored *)
+      (* user_arity ignored *)
+      let cst = check_conv cst conv_sort env p1.mind_sort p2.mind_sort in
+      check (fun p -> p.mind_nrealargs);
+      (* kelim ignored *)
+      (* listrec ignored *)
+      (* finite done *)
+      (* nparams done *)
+      (* params_ctxt done *)
+      let cst = check_conv cst conv env p1.mind_nf_arity p2.mind_nf_arity in
+	cst
+  in
+  let check_cons_types i cst p1 p2 =
+    array_fold_left2 
+      (fun cst t1 t2 -> check_conv cst conv env t1 t2)
+      cst
+      (arities_of_specif kn (mib1,p1))
+      (arities_of_specif kn (mib2,p2))
+  in
+  let check f = if f mib1 <> f mib2 then error () in
+  check (fun mib -> mib.mind_finite);
+  check (fun mib -> mib.mind_ntypes);
+  assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
+  assert (Array.length mib1.mind_packets >= 1 
+	    && Array.length mib2.mind_packets >= 1);
+
+       (* TODO: we should allow renaming of parameters at least ! *)
+  check (fun mib -> mib.mind_packets.(0).mind_nparams);
+  check (fun mib -> mib.mind_packets.(0).mind_params_ctxt); 
+
+  begin 
+    match mib2.mind_equiv with
+      | None -> ()
+      | Some kn2' -> 
+	  let kn2 = scrape_mind env kn2' in
+	  let kn1 = match mib1.mind_equiv with
+	      None -> kn
+	    | Some kn1' -> scrape_mind env kn1'
+	  in
+	    if kn1 <> kn2 then error ()
+  end;
+  (* we first check simple things *)
+  let cst = 
+    array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
+  in
+  (* and constructor types in the end *)
+  let cst = 
+    array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
+  in
+    cst
+    
+let check_constant cst env msid1 l info1 cb2 spec2 = 
+  let error () = error_not_match l spec2 in
+  let check_conv cst f = check_conv_error error cst f in
+  let cb1 = 
+    match info1 with
+      | Constant cb -> cb
+      | _ -> error ()
+  in 
+    assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+  (*Start by checking types*)
+    let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in
+    match cb2.const_body with
+      | None -> cst
+      | Some lc2 ->
+	  let c2 = Declarations.force lc2 in
+	  let c1 = match cb1.const_body with
+	    | Some lc1 -> Declarations.force lc1
+	    | None -> mkConst (make_kn (MPself msid1) empty_dirpath l)
+	  in
+	    check_conv cst conv env c1 c2
+	      
+let rec check_modules cst env msid1 l msb1 msb2 =
+  let mp = (MPdot(MPself msid1,l)) in
+  let mty1 = strengthen env msb1.msb_modtype mp in
+  let cst = check_modtypes cst env mty1 msb2.msb_modtype false in
+  begin
+    match msb1.msb_equiv, msb2.msb_equiv with
+      | _, None -> ()
+      | None, Some mp2 -> 
+	  check_modpath_equiv env mp mp2
+      | Some mp1, Some mp2 ->
+	  check_modpath_equiv env mp1 mp2
+  end;
+  cst
+	
+
+and check_signatures cst env' (msid1,sig1) (msid2,sig2') = 
+  let mp1 = MPself msid1 in
+  let env = add_signature mp1 sig1 env' in 
+  let sig2 = subst_signature_msid msid2 mp1 sig2' in
+  let map1 = make_label_map msid1 sig1 in
+  let check_one_body cst (l,spec2) = 
+    let info1 = 
+      try 
+	Labmap.find l map1 
+      with 
+	  Not_found -> error_no_such_label l 
+    in
+      match spec2 with
+	| SPBconst cb2 ->
+	    check_constant cst env msid1 l info1 cb2 spec2
+	| SPBmind mib2 -> 
+	    check_inductive cst env msid1 l info1 mib2 spec2
+	| SPBmodule msb2 -> 
+	    let msb1 = 
+	      match info1 with
+		| Module msb -> msb
+		| _ -> error_not_match l spec2
+	    in
+	      check_modules cst env msid1 l msb1 msb2
+	| SPBmodtype mtb2 ->
+	    let mtb1 = 
+	      match info1 with
+		| Modtype mtb -> mtb
+		| _ -> error_not_match l spec2
+	    in
+	      check_modtypes cst env mtb1 mtb2 true
+  in
+    List.fold_left check_one_body cst sig2
+    
+and check_modtypes cst env mtb1 mtb2 equiv = 
+  if mtb1==mtb2 then (); (* just in case  :) *)
+  let mtb1' = scrape_modtype env mtb1 in
+  let mtb2' = scrape_modtype env mtb2 in
+    if mtb1'==mtb2' then ();
+    match mtb1', mtb2' with
+      | MTBsig (msid1,list1), 
+	MTBsig (msid2,list2) -> 
+	  let cst = check_signatures cst env (msid1,list1) (msid2,list2) in
+	  if equiv then
+	    check_signatures cst env (msid2,list2) (msid1,list1) 
+	  else
+	    cst
+      | MTBfunsig (arg_id1,arg_t1,body_t1), 
+	MTBfunsig (arg_id2,arg_t2,body_t2) ->
+	  let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
+	    (* contravariant *)
+	  let env' = 
+	    add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	  in
+	  let body_t1' = 
+	    subst_modtype 
+	      (map_mbid arg_id1 (MPbound arg_id2)) 
+	      body_t1
+	  in
+	  check_modtypes cst env' body_t1' body_t2 equiv
+      | MTBident _ , _ -> anomaly "Subtyping: scrape failed"
+      | _ , MTBident _ -> anomaly "Subtyping: scrape failed"
+      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+	  
+let check_subtypes env sup super = 
+  check_modtypes Constraint.empty env sup super false
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
new file mode 100644
index 00000000..af09dafc
--- /dev/null
+++ b/kernel/subtyping.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  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: subtyping.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Univ
+open Declarations
+open Environ
+(*i*)
+
+val check_subtypes : env -> module_type_body -> module_type_body -> constraints
+
+
diff --git a/kernel/term.ml b/kernel/term.ml
new file mode 100644
index 00000000..30e73e4f
--- /dev/null
+++ b/kernel/term.ml
@@ -0,0 +1,1186 @@
+(************************************************************************)
+(*  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: term.ml,v 1.95.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+(* This module instanciates the structure of generic deBruijn terms to Coq *)
+
+open Util
+open Pp
+open Names
+open Univ
+open Esubst
+
+(* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *)
+
+type existential_key = int
+type metavariable = int
+
+(* This defines Cases annotations *)
+type pattern_source = DefaultPat of int | RegularPat
+type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_nargs : int; (* number of real args of the inductive type *)
+    style     : case_style;
+    source    : pattern_source array }
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  }
+
+(* Sorts. *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents                      (* proposition types *)
+  | Type of universe
+      
+let mk_Set  = Prop Pos
+let mk_Prop = Prop Null
+
+type sorts_family = InProp | InSet | InType
+
+let family_of_sort = function
+  | Prop Null -> InProp
+  | Prop Pos -> InSet
+  | Type _ -> InType
+
+(********************************************************************)
+(*       Constructions as implemented                               *)
+(********************************************************************)
+
+(* [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type ('constr, 'types) prec_declaration =
+    name array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+(* [Var] is used for named variables and [Rel] for variables as
+   de Bruijn indices. *)
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of identifier
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of sorts
+  | Cast      of 'constr * 'types
+  | Prod      of name * 'types * 'types
+  | Lambda    of name * 'types * 'constr
+  | LetIn     of name * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant
+  | Ind       of inductive
+  | Construct of constructor
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+
+(* Experimental *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of name * 'types * 'types
+  | LetInType  of name * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+let kind_of_type = function
+  | Sort s -> SortType s
+  | Cast (c,t) -> CastType (c, t)
+  | Prod (na,t,c) -> ProdType (na, t, c)
+  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+  | App (c,l) -> AtomicType (c, l)
+  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
+    -> AtomicType (c,[||])
+  | (Lambda _ | Construct _) -> failwith "Not a type"
+
+(* constr is the fixpoint of the previous type. Requires option
+   -rectypes of the Caml compiler to be set *)
+type constr = (constr,constr) kind_of_term
+
+type existential = existential_key * constr array
+type rec_declaration = name array * constr array * constr array
+type fixpoint = (int array * int) * rec_declaration
+type cofixpoint = int * rec_declaration
+
+(***************************)
+(* hash-consing functions  *)                         
+(***************************)
+
+let comp_term t1 t2 =
+  match t1, t2 with
+  | Rel n1, Rel n2 -> n1 = n2
+  | Meta m1, Meta m2 -> m1 == m2
+  | Var id1, Var id2 -> id1 == id2
+  | Sort s1, Sort s2 -> s1 == s2
+  | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2
+  | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+  | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+  | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
+      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
+  | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2
+  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2
+  | Const c1, Const c2 -> c1 == c2
+  | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
+  | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
+      sp1 == sp2 & i1 = i2 & j1 = j2
+  | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+      ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2
+  | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_for_all2 (==) lna1 lna2
+      & array_for_all2 (==) tl1 tl2
+      & array_for_all2 (==) bl1 bl2
+  | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_for_all2 (==) lna1 lna2
+      & array_for_all2 (==) tl1 tl2
+      & array_for_all2 (==) bl1 bl2
+  | _ -> false
+
+let hash_term (sh_rec,(sh_sort,sh_kn,sh_na,sh_id)) t =
+  match t with
+  | Rel _ -> t
+  | Meta x -> Meta x
+  | Var x -> Var (sh_id x)
+  | Sort s -> Sort (sh_sort s)
+  | Cast (c,t) -> Cast (sh_rec c, sh_rec t)
+  | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c)
+  | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c)
+  | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c)
+  | App (c,l) -> App (sh_rec c, Array.map sh_rec l)
+  | Evar (e,l) -> Evar (e, Array.map sh_rec l)
+  | Const c -> Const (sh_kn c)
+  | Ind (kn,i) -> Ind (sh_kn kn,i)
+  | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j)
+  | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *)
+      Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      Fix (ln,(Array.map sh_na lna,
+                 Array.map sh_rec tl,
+                 Array.map sh_rec bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      CoFix (ln,(Array.map sh_na lna,
+                   Array.map sh_rec tl,
+                   Array.map sh_rec bl))
+
+module Hconstr =
+  Hashcons.Make(
+    struct
+      type t = constr
+      type u = (constr -> constr) *
+               ((sorts -> sorts) * (kernel_name -> kernel_name)
+		* (name -> name) * (identifier -> identifier))
+      let hash_sub = hash_term
+      let equal = comp_term
+      let hash = Hashtbl.hash
+    end)
+
+let hcons_term (hsorts,hkn,hname,hident) =
+  Hashcons.recursive_hcons Hconstr.f (hsorts,hkn,hname,hident)
+
+(* Constructs a DeBrujin index with number n *)
+let rels =
+  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
+    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
+
+let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
+
+(* Construct a type *)
+let mkSort s = Sort s
+
+(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
+(* (that means t2 is declared as the type of t1) *)
+let mkCast (t1,t2) =
+  match t1 with
+    | Cast (t,_) -> Cast (t,t2)
+    | _ -> Cast (t1,t2)
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd (x,t1,t2) = Prod (x,t1,t2)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* We ensure applicative terms have at least one argument and the
+   function is not itself an applicative term *)
+let mkApp (f, a) = 
+  if a=[||] then f else
+    match f with
+      | App (g, cl) -> App (g, Array.append cl a)
+      | _ -> App (f, a)
+
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+let mkConst c = Const c
+
+(* Constructs an existential variable *)
+let mkEvar e = Evar e
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+let mkInd m = Ind m
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+let mkConstruct c = Construct c
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
+
+let mkFix fix = Fix fix
+
+let mkCoFix cofix = CoFix cofix
+
+let kind_of_term c = c
+
+(************************************************************************)
+(*    kind_of_term = constructions as seen by the user                 *)
+(************************************************************************)
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+let kind_of_term = kind_of_term
+
+
+(* En vue d'un kind_of_type : constr -> hnftype ??? *)
+type hnftype =
+  | HnfSort   of sorts
+  | HnfProd   of name * constr * constr
+  | HnfAtom   of constr
+  | HnfInd of inductive * constr array
+
+(**********************************************************************)
+(*          Non primitive term destructors                            *)
+(**********************************************************************)
+
+(* Destructor operations : partial functions 
+   Raise invalid_arg "dest*" if the const has not the expected form *)
+
+(* Destructs a DeBrujin index *)
+let destRel c = match kind_of_term c with
+  | Rel n -> n
+  | _ -> invalid_arg "destRel"
+
+(* Destructs an existential variable *)
+let destMeta c = match kind_of_term c with
+  | Meta n -> n
+  | _ -> invalid_arg "destMeta"
+
+let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
+
+(* Destructs a variable *)
+let destVar c = match kind_of_term c with
+  | Var id -> id
+  | _ -> invalid_arg "destVar"
+
+(* Destructs a type *)
+let isSort c = match kind_of_term c with
+  | Sort s -> true
+  | _ -> false
+
+let destSort c = match kind_of_term c with
+  | Sort s -> s
+  | _ -> invalid_arg "destSort"
+
+let rec isprop c = match kind_of_term c with
+  | Sort (Prop _) -> true
+  | Cast (c,_) -> isprop c
+  | _ -> false
+
+let rec is_Prop c = match kind_of_term c with
+  | Sort (Prop Null) -> true
+  | Cast (c,_) -> is_Prop c
+  | _ -> false
+
+let rec is_Set c = match kind_of_term c with
+  | Sort (Prop Pos) -> true
+  | Cast (c,_) -> is_Set c
+  | _ -> false
+
+let rec is_Type c = match kind_of_term c with
+  | Sort (Type _) -> true
+  | Cast (c,_) -> is_Type c
+  | _ -> false
+
+let isType = function
+  | Type _ -> true
+  | _ -> false
+
+let is_small = function
+  | Prop _ -> true
+  | _ -> false
+
+let iskind c = isprop c or is_Type c
+
+let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2)
+
+(* Tests if an evar *)
+let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
+
+(* Destructs a casted term *)
+let destCast c = match kind_of_term c with 
+  | Cast (t1, t2) -> (t1,t2)
+  | _ -> invalid_arg "destCast"
+
+let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false
+
+(* Tests if a de Bruijn index *)
+let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
+
+(* Tests if a variable *)
+let isVar c = match kind_of_term c with Var _ -> true | _ -> false
+
+(* Tests if an inductive *)
+let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
+
+(* Destructs the product (x:t1)t2 *)
+let destProd c = match kind_of_term c with 
+  | Prod (x,t1,t2) -> (x,t1,t2) 
+  | _ -> invalid_arg "destProd"
+
+(* Destructs the abstraction [x:t1]t2 *)
+let destLambda c = match kind_of_term c with 
+  | Lambda (x,t1,t2) -> (x,t1,t2) 
+  | _ -> invalid_arg "destLambda"
+
+(* Destructs the let [x:=b:t1]t2 *)
+let destLetIn c = match kind_of_term c with 
+  | LetIn (x,b,t1,t2) -> (x,b,t1,t2) 
+  | _ -> invalid_arg "destProd"
+
+(* Destructs an application *)
+let destApplication c = match kind_of_term c with
+  | App (f,a) -> (f, a)
+  | _ -> invalid_arg "destApplication"
+
+let isApp c = match kind_of_term c with App _ -> true | _ -> false
+
+(* Destructs a constant *)
+let destConst c = match kind_of_term c with
+  | Const kn -> kn
+  | _ -> invalid_arg "destConst"
+
+let isConst c = match kind_of_term c with Const _ -> true | _ -> false
+
+(* Destructs an existential variable *)
+let destEvar c = match kind_of_term c with
+  | Evar (kn, a as r) -> r
+  | _ -> invalid_arg "destEvar"
+
+let num_of_evar c = match kind_of_term c with
+  | Evar (n, _) -> n
+  | _ -> anomaly "num_of_evar called with bad args"
+
+(* Destructs a (co)inductive type named kn *)
+let destInd c = match kind_of_term c with
+  | Ind (kn, a as r) -> r
+  | _ -> invalid_arg "destInd"
+
+(* Destructs a constructor *)
+let destConstruct c = match kind_of_term c with
+  | Construct (kn, a as r) -> r
+  | _ -> invalid_arg "dest"
+
+let isConstruct c = match kind_of_term c with
+    Construct _ -> true | _ -> false
+
+(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+let destCase c = match kind_of_term c with
+  | Case (ci,p,c,v) -> (ci,p,c,v)
+  | _ -> anomaly "destCase"
+
+let destFix c = match kind_of_term c with 
+  | Fix fix -> fix
+  | _ -> invalid_arg "destFix"
+	
+let destCoFix c = match kind_of_term c with 
+  | CoFix cofix -> cofix
+  | _ -> invalid_arg "destCoFix"
+
+(******************************************************************)
+(* Flattening and unflattening of embedded applications and casts *)
+(******************************************************************)
+
+(* flattens application lists *)
+let rec collapse_appl 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,_) when isApp c -> collapse_rec c cl2
+	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
+      in 
+      collapse_rec f cl
+  | _ -> c
+
+let rec decompose_app c =
+  match kind_of_term (collapse_appl c) with
+    | App (f,cl) -> (f, Array.to_list cl)
+    | Cast (c,t) -> decompose_app c
+    | _ -> (c,[])
+
+(* 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
+
+(****************************************************************************)
+(*              Functions to recur through subterms                         *)
+(****************************************************************************)
+
+(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+let fold_constr f acc c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> acc
+  | Cast (c,t) -> f (f acc c) t
+  | Prod (_,t,c) -> f (f acc t) c
+  | Lambda (_,t,c) -> f (f acc t) c
+  | LetIn (_,b,t,c) -> f (f (f acc b) t) c
+  | App (c,l) -> Array.fold_left f (f acc c) l
+  | Evar (_,l) -> Array.fold_left f acc l
+  | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+  | Fix (_,(lna,tl,bl)) ->
+      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
+      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
+  | CoFix (_,(lna,tl,bl)) ->
+      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
+      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
+
+(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+let iter_constr f c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,t) -> f c; f t
+  | Prod (_,t,c) -> f t; f c
+  | Lambda (_,t,c) -> f t; f c
+  | LetIn (_,b,t,c) -> f b; f t; f c
+  | App (c,l) -> f c; Array.iter f l
+  | Evar (_,l) -> Array.iter f l
+  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
+  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+
+(* [iter_constr_with_binders g f n c] iters [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; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let iter_constr_with_binders g f n c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,t) -> f n c; f n t
+  | Prod (_,t,c) -> f n t; f (g n) c
+  | Lambda (_,t,c) -> f n t; f (g n) c
+  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
+  | App (c,l) -> f n c; Array.iter (f n) l
+  | Evar (_,l) -> Array.iter (f n) l
+  | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
+  | Fix (_,(_,tl,bl)) -> 
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+  | CoFix (_,(_,tl,bl)) ->
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+
+(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+let map_constr f c = match kind_of_term c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (c,t) -> mkCast (f c, f t)
+  | Prod (na,t,c) -> mkProd (na, f t, f c)
+  | Lambda (na,t,c) -> mkLambda (na, f t, f c)
+  | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c)
+  | App (c,l) -> mkApp (f c, Array.map f l)
+  | Evar (e,l) -> mkEvar (e, Array.map f l)
+  | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      mkFix (ln,(lna,Array.map f tl,Array.map f bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      mkCoFix (ln,(lna,Array.map f tl,Array.map f bl))
+
+(* [map_constr_with_binders 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; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let map_constr_with_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 l) c)
+  | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c)
+  | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g 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' = iterate g (Array.length tl) l in
+      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let l' = iterate g (Array.length tl) l in
+      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_constr f t1 t2 =
+  match kind_of_term t1, kind_of_term t2 with
+  | Rel n1, Rel n2 -> n1 = n2
+  | Meta m1, Meta m2 -> m1 = m2
+  | Var id1, Var id2 -> id1 = id2
+  | Sort s1, Sort s2 -> s1 = s2
+  | Cast (c1,_), _ -> f c1 t2
+  | _, Cast (c2,_) -> f t1 c2
+  | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
+  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
+  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
+  | App (c1,l1), App (c2,l2) ->
+      if Array.length l1 = Array.length l2 then
+        f c1 c2 & array_for_all2 f l1 l2
+      else
+        let (h1,l1) = decompose_app t1 in        
+        let (h2,l2) = decompose_app t2 in
+        if List.length l1 = List.length l2 then
+          f h1 h2 & List.for_all2 f l1 l2
+        else false
+  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
+  | Const c1, Const c2 -> c1 = c2
+  | Ind c1, Ind c2 -> c1 = c2
+  | Construct c1, Construct c2 -> c1 = c2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
+  | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | _ -> false
+
+(***************************************************************************)
+(*     Type of assumptions                                                 *)
+(***************************************************************************)
+
+type types = constr
+
+let type_app f tt = f tt
+
+let body_of_type ty = ty
+
+type named_declaration = identifier * constr option * types
+type rel_declaration = name * constr option * types
+
+let map_named_declaration f (id, v, ty) = (id, option_app f v, f ty)
+let map_rel_declaration = map_named_declaration
+
+(****************************************************************************)
+(*              Functions for dealing with constr terms                     *)
+(****************************************************************************)
+
+(*********************)
+(*     Occurring     *)
+(*********************)
+
+exception LocalOccur
+
+(* (closedn n M) raises FreeVar if a variable of height greater than n
+   occurs in M, returns () otherwise *)
+
+let closedn = 
+  let rec closed_rec n c = match kind_of_term c with
+    | Rel m -> if m>n then raise LocalOccur
+    | _ -> iter_constr_with_binders succ closed_rec n c
+  in 
+  closed_rec
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+
+let closed0 term =
+  try closedn 0 term; true with LocalOccur -> false
+
+(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
+
+let noccurn n term = 
+  let rec occur_rec n c = match kind_of_term c with
+    | Rel m -> if m = n then raise LocalOccur
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M 
+  for n <= p < n+m *)
+
+let noccur_between 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 LocalOccur
+    | _        -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* Checking function for terms containing existential variables.
+ The function [noccur_with_meta] considers the fact that
+ each existential variable (as well as each isevar)
+ in the term appears applied to its local context,
+ which may contain the CoFix variables. These occurrences of CoFix variables
+ are not considered *)
+
+let noccur_with_meta 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 LocalOccur
+    | App(f,cl) ->
+	(match kind_of_term f with
+           | Cast (c,_) when isMeta c -> ()
+           | Meta _ -> ()
+	   | _ -> iter_constr_with_binders succ occur_rec n c)
+    | Evar (_, _) -> ()
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in
+  try (occur_rec n term; true) with LocalOccur -> false
+
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+(* The generic lifting function *)
+let rec exliftn el c = match kind_of_term c with
+  | Rel i -> mkRel(reloc_rel i el)
+  | _ -> map_constr_with_binders el_lift exliftn el c
+
+(* Lifting the binding depth across k bindings *)
+
+let liftn k n = 
+  match el_liftn (pred n) (el_shft k ELID) with
+    | ELID -> (fun c -> c)
+    | el -> exliftn el
+ 
+let lift k = liftn k 1
+
+(*********************)
+(*   Substituting    *)
+(*********************)
+
+(* (subst1 M c) substitutes M for Rel(1) in c 
+   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
+   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
+
+(* 1st : general case *)
+
+type info = Closed | Open | Unknown
+type 'a substituend = { mutable sinfo: info; sit: 'a }
+
+let rec lift_substituend depth s =
+  match s.sinfo with
+    | Closed -> s.sit
+    | Open -> lift depth s.sit
+    | Unknown ->
+        s.sinfo <- if closed0 s.sit then Closed else Open;
+        lift_substituend depth s
+
+let make_substituend c = { sinfo=Unknown; sit=c }
+
+let substn_many lamv n =
+  let lv = Array.length lamv in 
+  let rec substrec depth c = match kind_of_term c with
+    | Rel k     ->
+        if k<=depth then 
+	  c
+        else if k-depth <= lv then
+          lift_substituend depth lamv.(k-depth-1)
+        else 
+	  mkRel (k-lv)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in 
+  substrec n
+
+(*
+let substkey = Profile.declare_profile "substn_many";;
+let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
+*)
+
+let substnl laml k =
+  substn_many (Array.map make_substituend (Array.of_list laml)) k
+let substl laml =
+  substn_many (Array.map make_substituend (Array.of_list laml)) 0
+let subst1 lam = substl [lam]
+
+let substl_decl laml (id,bodyopt,typ as d) =
+  match bodyopt with
+    | None -> (id,None,substl laml typ)
+    | Some body -> (id, Some (substl laml body), type_app (substl laml) typ)
+let subst1_decl lam = substl_decl [lam]
+
+(* (thin_val sigma) removes identity substitutions from sigma *)
+
+let rec thin_val = function
+  | [] -> []
+  | (((id,{ sit = v }) as s)::tl) when isVar v -> 
+      if id = destVar v then thin_val tl else s::(thin_val tl)
+  | h::tl -> h::(thin_val tl)
+
+(* (replace_vars sigma M) applies substitution sigma to term M *)
+let replace_vars var_alist = 
+  let var_alist =
+    List.map (fun (str,c) -> (str,make_substituend c)) var_alist in
+  let var_alist = thin_val var_alist in 
+  let rec substrec n c = match kind_of_term c with
+    | Var x ->
+        (try lift_substituend n (List.assoc x var_alist)
+         with Not_found -> c)
+    | _ -> map_constr_with_binders succ substrec n c
+  in 
+  if var_alist = [] then (function x -> x) else substrec 0
+
+(*
+let repvarkey = Profile.declare_profile "replace_vars";;
+let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
+*)
+
+(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+let subst_var str = replace_vars [(str, mkRel 1)]
+
+(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
+let substn_vars p vars =
+  let _,subst =
+    List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars
+  in replace_vars (List.rev subst)
+
+let subst_vars = substn_vars 1
+
+(* 
+map_kn : (kernel_name -> kernel_name) -> constr -> constr
+
+This should be rewritten to prevent duplication of constr's when not
+necessary.
+For now, it uses map_constr and is rather ineffective
+*)
+
+let rec map_kn f c = 
+  let func = map_kn f in
+    match kind_of_term c with
+      | Const kn -> 
+	  mkConst (f kn)
+      | Ind (kn,i) -> 
+	  mkInd (f kn,i)
+      | Construct ((kn,i),j) -> 
+	  mkConstruct ((f kn,i),j)
+      | Case (ci,p,c,l) ->
+	  let ci' = { ci with ci_ind = let (kn,i) = ci.ci_ind in f kn, i } in
+	  mkCase (ci', func p, func c, array_smartmap func l) 
+      | _ -> map_constr func c
+
+let subst_mps sub = 
+  map_kn (subst_kn sub)
+
+
+(*********************)
+(* Term constructors *)
+(*********************)
+
+(* Constructs a DeBrujin index with number n *)
+let mkRel = mkRel
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta = mkMeta
+
+(* Constructs a Variable named id *)
+let mkVar = mkVar
+
+(* Construct a type *)
+let mkProp   = mkSort mk_Prop
+let mkSet    = mkSort mk_Set
+let mkType u = mkSort (Type u)
+let mkSort   = function
+  | Prop Null -> mkProp (* Easy sharing *)
+  | Prop Pos -> mkSet
+  | s -> mkSort s
+
+let prop = mk_Prop
+and spec = mk_Set
+and type_0 = Type prop_univ
+
+(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
+(* (that means t2 is declared as the type of t1) *)
+let mkCast = mkCast
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd = mkProd
+let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c)
+let mkProd_string   s t c = mkProd (Name (id_of_string s), t, c)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda = mkLambda
+let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c)
+let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn = mkLetIn
+let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2)
+
+(* 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)
+
+let mkNamedProd_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedProd id t c
+    | Some b -> mkNamedLetIn id b t c
+
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+let mkLambda_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkLambda (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
+
+let mkNamedLambda_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedLambda id t c
+    | Some b -> mkNamedLetIn id 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 mkNamedProd_wo_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedProd id t c
+    | Some b -> subst1 b (subst_var id c)
+
+(* non-dependent product t1 -> t2 *)
+let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* We ensure applicative terms have at most one arguments and the
+   function is not itself an applicative term *)
+let mkApp = mkApp
+
+let mkAppA v =
+  let l = Array.length v in
+  if l=0 then anomaly "mkAppA received an empty array"
+  else mkApp (v.(0), Array.sub v 1 (Array.length v -1))
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+let mkConst = mkConst
+
+(* Constructs an existential variable *)
+let mkEvar = mkEvar
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+let mkInd = mkInd
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+let mkConstruct = mkConstruct
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase = mkCase
+let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac)
+
+(* If recindxs = [|i1,...in|] 
+      funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then    
+
+      mkFix ((recindxs,i),(funnames,typarray,bodies))
+   
+   constructs the ith function of the block  
+
+    Fixpoint f1 [ctx1] : t1 := b1
+    with     f2 [ctx2] : t2 := b2
+    ...
+    with     fn [ctxn] : tn := bn.
+
+   where the lenght of the jth context is ij.
+*)
+
+let mkFix = mkFix
+
+(* If funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then 
+
+      mkCoFix (i,(funnames,typsarray,bodies))
+
+   constructs the ith function of the block  
+   
+    CoFixpoint f1 : t1 := b1
+    with       f2 : t2 := b2
+    ...
+    with       fn : tn := bn.
+*)
+let mkCoFix = mkCoFix
+
+(* Construct an implicit *)
+let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0))
+let mkImplicit = mkSort implicit_sort
+
+let rec strip_outer_cast c = match kind_of_term c with
+  | Cast (c,_) -> strip_outer_cast c
+  | _ -> c
+
+(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
+
+let under_outer_cast f c =  match kind_of_term c with
+  | Cast (b,t) -> mkCast (f b,f t)
+  | _ -> f c
+
+let rec under_casts f c = match kind_of_term c with
+  | Cast (c,t) -> mkCast (under_casts f c, t)
+  | _            -> f c
+
+(***************************)
+(* Other term constructors *)
+(***************************)
+
+let abs_implicit c = mkLambda (Anonymous, mkImplicit, c)
+let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a)
+let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a)
+
+(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
+let prodn n env b =
+  let rec prodrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> prodrec (n-1,  l, mkProd (v,t,b))
+    | _ -> assert false
+  in 
+  prodrec (n,env,b)
+
+(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *)
+let compose_prod l b = prodn (List.length l) l b
+
+(* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *)
+let lamn n env b =
+  let rec lamrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> lamrec (n-1,  l, mkLambda (v,t,b))
+    | _ -> assert false
+  in 
+  lamrec (n,env,b)
+
+(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *)
+let compose_lam l b = lamn (List.length l) l b
+
+let applist (f,l) = mkApp (f, Array.of_list l)
+
+let applistc f l = mkApp (f, Array.of_list l)
+
+let appvect = mkApp
+	    
+let appvectc f l = mkApp (f,l)
+		     
+(* to_lambda n (x1:T1)...(xn:Tn)T =
+ * [x1:T1]...[xn:Tn]T *)
+let rec to_lambda n prod =
+  if n = 0 then 
+    prod 
+  else 
+    match kind_of_term prod with 
+      | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
+      | Cast (c,_) -> to_lambda n c
+      | _   -> errorlabstrm "to_lambda" (mt ())                      
+
+let rec to_prod n lam =
+  if n=0 then 
+    lam
+  else   
+    match kind_of_term lam with 
+      | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
+      | Cast (c,_) -> to_prod n c
+      | _   -> errorlabstrm "to_prod" (mt ())                      
+	    
+(* pseudo-reduction rule:
+ * [prod_app  s (Prod(_,B)) N --> B[N]
+ * with an strip_outer_cast on the first argument to produce a product *)
+
+let prod_app t n =
+  match kind_of_term (strip_outer_cast t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ ->
+	errorlabstrm "prod_app"
+	  (str"Needed a product, but didn't find one" ++ fnl ())
+
+
+(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
+let prod_appvect t nL = Array.fold_left prod_app t nL
+
+(* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *)
+let prod_applist t nL = List.fold_left prod_app t nL
+
+(*********************************)
+(* Other term destructors        *)
+(*********************************)
+
+(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
+let decompose_prod = 
+  let rec prodec_rec l c = match kind_of_term c with
+    | Prod (x,t,c) -> prodec_rec ((x,t)::l) c
+    | Cast (c,_)   -> prodec_rec l c
+    | _              -> l,c
+  in 
+  prodec_rec []
+
+(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
+let decompose_lam = 
+  let rec lamdec_rec l c = match kind_of_term c with
+    | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
+    | Cast (c,_)     -> lamdec_rec l c
+    | _                -> l,c
+  in 
+  lamdec_rec []
+
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_prod_n n =
+  if n < 0 then error "decompose_prod_n: integer parameter must be positive";
+  let rec prodec_rec l n c = 
+    if n=0 then l,c 
+    else match kind_of_term c with 
+      | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
+      | Cast (c,_)   -> prodec_rec l n c
+      | _ -> error "decompose_prod_n: not enough products"
+  in 
+  prodec_rec [] n 
+
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_lam_n n =
+  if n < 0 then error "decompose_lam_n: integer parameter must be positive";
+  let rec lamdec_rec l n c = 
+    if n=0 then l,c 
+    else match kind_of_term c with 
+      | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
+      | Cast (c,_)     -> lamdec_rec l n c
+      | _ -> error "decompose_lam_n: not enough abstractions"
+  in 
+  lamdec_rec [] n 
+
+(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction
+ * gives n (casts are ignored) *)
+let nb_lam = 
+  let rec nbrec n c = match kind_of_term c with
+    | Lambda (_,_,c) -> nbrec (n+1) c
+    | Cast (c,_) -> nbrec n c
+    | _ -> n
+  in 
+  nbrec 0
+    
+(* similar to nb_lam, but gives the number of products instead *)
+let nb_prod = 
+  let rec nbrec n c = match kind_of_term c with
+    | Prod (_,_,c) -> nbrec (n+1) c
+    | Cast (c,_) -> nbrec n c
+    | _ -> n
+  in 
+  nbrec 0
+
+(* Rem: end of import from old module Generic *)
+
+(*******************************)
+(*  alpha conversion functions *)                         
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let rec eq_constr m n = 
+  (m==n) or
+  compare_constr eq_constr m n
+let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+(*******************)
+(*  hash-consing   *)                         
+(*******************)
+
+module Htype =
+  Hashcons.Make(
+    struct
+      type t = types
+      type u = (constr -> constr) * (sorts -> sorts)
+(*
+      let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ}
+      let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ
+*)
+(**)
+      let hash_sub (hc,hs) j = hc j
+      let equal j1 j2 = j1==j2
+(**)
+      let hash = Hashtbl.hash
+    end)
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      type t = sorts
+      type u = universe -> universe
+      let hash_sub huniv = function
+          Prop c -> Prop c
+        | Type u -> Type (huniv u)
+      let equal s1 s2 =
+        match (s1,s2) with
+            (Prop c1, Prop c2) -> c1=c2
+          | (Type u1, Type u2) -> u1 == u2
+          |_ -> false
+      let hash = Hashtbl.hash
+    end)
+
+let hsort = Hsorts.f
+
+let hcons_constr (hkn,hdir,hname,hident,hstr) =
+  let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
+  let hcci = hcons_term (hsortscci,hkn,hname,hident) in
+  let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
+  (hcci,htcci)
+
+let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
diff --git a/kernel/term.mli b/kernel/term.mli
new file mode 100644
index 00000000..a5e5c081
--- /dev/null
+++ b/kernel/term.mli
@@ -0,0 +1,525 @@
+(************************************************************************)
+(*  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: term.mli,v 1.101.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+(*i*)
+
+(*s The sorts of CCI. *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents       (* Prop and Set *)
+  | Type of Univ.universe  (* Type *)
+
+val mk_Set  : sorts
+val mk_Prop : sorts
+val type_0  : sorts
+
+(*s The sorts family of CCI. *)
+
+type sorts_family = InProp | InSet | InType
+
+val family_of_sort : sorts -> sorts_family
+
+(*s Useful types *)
+
+(*s Existential variables *)
+type existential_key = int
+
+(*s Existential variables *)
+type metavariable = int
+
+(*s Case annotation *)
+type pattern_source = DefaultPat of int | RegularPat
+type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_nargs : int; (* number of real args of the inductive type *)
+    style     : case_style;
+    source    : pattern_source array }
+(* the integer is the number of real args, needed for reduction *)
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  }
+
+(*s*******************************************************************)
+(* The type of constructions *)
+
+type constr
+
+(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
+   and application grouping *)
+val eq_constr : constr -> constr -> bool
+
+(* [types] is the same as [constr] but is intended to be used where a
+   {\em type} in CCI sense is expected (Rem:plurial form since [type] is a
+   reserved ML keyword) *)
+
+type types = constr
+
+(*s Functions about [types] *)
+
+val type_app : (constr -> constr) -> types -> types
+
+val body_of_type : types -> constr
+
+(*s Functions for dealing with constr terms.
+  The following functions are intended to simplify and to uniform the 
+  manipulation of terms. Some of these functions may be overlapped with
+  previous ones. *)
+
+(*s Term constructors. *)
+
+(* Constructs a DeBrujin index (DB indices begin at 1) *)
+val mkRel : int -> constr
+
+(* Constructs a Variable *)
+val mkVar : identifier -> constr
+
+(* Constructs an patvar named "?n" *)
+val mkMeta : metavariable -> constr
+
+(* Constructs an existential variable *)
+type existential = existential_key * constr array
+val mkEvar : existential -> constr
+
+(* Construct a sort *)
+val mkSort : sorts -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+
+(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the 
+   type $t_2$ (that means t2 is declared as the type of t1). *)
+val mkCast : constr * types -> constr
+
+(* Constructs the product [(x:t1)t2] *)
+val mkProd : name * types * types -> types
+val mkNamedProd : identifier -> types -> types -> types
+(* non-dependant product $t_1 \rightarrow t_2$, an alias for
+   [(_:t1)t2]. Beware $t_2$ is NOT lifted.
+   Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *)
+val mkArrow : types -> types -> constr
+
+(* Constructs the abstraction $[x:t_1]t_2$ *)
+val mkLambda : name * types * constr -> constr
+val mkNamedLambda : identifier -> types -> constr -> constr
+
+(* Constructs the product [let x = t1 : t2 in t3] *)
+val mkLetIn : name * constr * types * constr -> constr
+val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
+
+(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+   $(f~t_1~\dots~t_n)$. *)
+val mkApp : constr * constr array -> constr
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+val mkConst : constant -> constr
+
+(* Inductive types *)
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+val mkInd : inductive -> constr
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+val mkConstruct : constructor -> constr
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+val mkCase : case_info * constr * constr * constr array -> constr
+
+(* If [recindxs = [|i1,...in|]]
+      [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [|b1,.....bn|]]
+   then [ mkFix ((recindxs,i), funnames, typarray, bodies) ]
+   constructs the $i$th function of the block (counting from 0)
+
+    [Fixpoint f1 [ctx1] = b1
+     with     f2 [ctx2] = b2
+     ...
+     with     fn [ctxn] = bn.]
+
+   \noindent where the length of the $j$th context is $ij$.
+*)
+type rec_declaration = name array * types array * constr array
+type fixpoint = (int array * int) * rec_declaration
+val mkFix : fixpoint -> constr
+
+(* If [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [b1,.....bn]] \par\noindent
+   then [mkCoFix (i, (typsarray, funnames, bodies))]
+   constructs the ith function of the block  
+   
+    [CoFixpoint f1 = b1
+     with       f2 = b2
+     ...
+     with       fn = bn.]
+ *)
+type cofixpoint = int * rec_declaration
+val mkCoFix : cofixpoint -> constr
+
+
+(*s Concrete type for making pattern-matching. *)
+
+(* [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type ('constr, 'types) prec_declaration =
+    name array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of identifier
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of sorts
+  | Cast      of 'constr * 'types
+  | Prod      of name * 'types * 'types
+  | Lambda    of name * 'types * 'constr
+  | LetIn     of name * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant
+  | Ind       of inductive
+  | Construct of constructor
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+val kind_of_term : constr -> (constr, types) kind_of_term
+
+(* Experimental *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of name * 'types * 'types
+  | LetInType  of name * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+val kind_of_type : types -> (constr, types) kind_of_type
+
+(*s Simple term case analysis. *)
+
+val isRel  : constr -> bool
+val isVar  : constr -> bool
+val isInd  : constr -> bool
+val isEvar : constr -> bool
+val isMeta : constr -> bool
+val isSort : constr -> bool
+val isCast : constr -> bool
+val isApp : constr -> bool
+val isConst : constr -> bool
+val isConstruct : constr -> bool
+
+val is_Prop : constr -> bool
+val is_Set  : constr -> bool
+val isprop : constr -> bool
+val is_Type : constr -> bool
+val iskind : constr -> bool
+val is_small : sorts -> bool
+
+(*s Term destructors. 
+   Destructor operations are partial functions and
+   raise [invalid_arg "dest*"] if the term has not the expected form. *)
+
+(* Destructs a DeBrujin index *)
+val destRel : constr -> int
+
+(* Destructs an existential variable *)
+val destMeta : constr -> metavariable
+
+(* Destructs a variable *)
+val destVar : constr -> identifier
+
+(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether 
+   [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *)
+val destSort : constr -> sorts
+
+(* Destructs a casted term *)
+val destCast : constr -> constr * types
+
+(* Destructs the product $(x:t_1)t_2$ *)
+val destProd : types -> name * types * types
+
+(* Destructs the abstraction $[x:t_1]t_2$ *)
+val destLambda : constr -> name * types * constr
+
+(* Destructs the let $[x:=b:t_1]t_2$ *)
+val destLetIn : constr -> name * constr * types * constr
+
+(* Destructs an application *)
+val destApplication : constr -> constr * constr array
+(* ... removing casts *)
+val decompose_app : constr -> constr * constr list
+
+(* Destructs a constant *)
+val destConst : constr -> constant
+
+(* Destructs an existential variable *)
+val destEvar : constr -> existential
+
+(* Destructs a (co)inductive type *)
+val destInd : constr -> inductive
+
+(* Destructs a constructor *)
+val destConstruct : constr -> constructor
+
+(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+val destCase : constr -> case_info * constr * constr * constr array
+
+(* Destructs the $i$th function of the block  
+   $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1
+    \mathit{with}     ~ f_2 ~ [ctx_2] = b_2
+    \dots
+    \mathit{with}     ~ f_n ~ [ctx_n] = b_n$,
+   where the lenght of the $j$th context is $ij$.
+*)
+val destFix : constr -> fixpoint
+
+val destCoFix : constr -> cofixpoint
+
+
+(*s A {\em declaration} has the form (name,body,type). It is either an
+    {\em assumption} if [body=None] or a {\em definition} if
+    [body=Some actualbody]. It is referred by {\em name} if [na] is an
+    identifier or by {\em relative index} if [na] is not an identifier
+    (in the latter case, [na] is of type [name] but just for printing
+    purpose *)
+
+type named_declaration = identifier * constr option * types
+type rel_declaration = name * constr option * types
+
+val map_named_declaration :
+  (constr -> constr) -> named_declaration -> named_declaration
+val map_rel_declaration :
+  (constr -> constr) -> rel_declaration -> rel_declaration
+
+(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkNamedProd_or_LetIn : named_declaration -> types -> types
+val mkNamedProd_wo_LetIn : named_declaration -> types -> types
+
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+val mkLambda_or_LetIn : rel_declaration -> constr -> constr
+val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
+
+(*s Other term constructors. *)
+
+val abs_implicit : constr -> constr
+val lambda_implicit : constr -> constr
+val lambda_implicit_lift : int -> constr -> constr
+
+(* [applist (f,args)] and co work as [mkApp] *)
+
+val applist : constr * constr list -> constr
+val applistc : constr -> constr list -> constr
+val appvect : constr * constr array -> constr
+val appvectc : constr -> constr array -> constr
+
+(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ 
+   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+val prodn : int -> (name * constr) list -> constr -> constr
+
+(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+   Inverse of [decompose_prod]. *)
+val compose_prod : (name * constr) list -> constr -> constr
+
+(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+val lamn : int -> (name * constr) list -> constr -> constr
+
+(* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+   Inverse of [decompose_lam] *)
+val compose_lam : (name * constr) list -> constr -> constr
+
+(* [to_lambda n l] 
+   = $[x_1:T_1]...[x_n:T_n]T$
+   where $l = (x_1:T_1)...(x_n:T_n)T$ *)
+val to_lambda : int -> constr -> constr
+
+(* [to_prod n l] 
+   = $(x_1:T_1)...(x_n:T_n)T$
+   where $l = [x_1:T_1]...[x_n:T_n]T$ *)
+val to_prod : int -> constr -> constr
+
+(* pseudo-reduction rule *)
+
+(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *)
+val prod_appvect : constr -> constr array -> constr
+val prod_applist : constr -> constr list -> constr
+
+(*s Other term destructors. *)
+
+(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair
+   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product.
+   It includes also local definitions *)
+val decompose_prod : constr -> (name*constr) list * constr
+
+(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair
+   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *)
+val decompose_lam : constr -> (name*constr) list * constr
+
+(* Given a positive integer n, transforms a product term 
+   $(x_1:T_1)..(x_n:T_n)T$
+   into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
+val decompose_prod_n : int -> constr -> (name * constr) list * constr
+
+(* Given a positive integer $n$, transforms a lambda term 
+   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+val decompose_lam_n : int -> constr -> (name * constr) list * constr
+
+(* [nb_lam] $[x_1:T_1]...[x_n:T_n]c$ where $c$ is not an abstraction
+   gives $n$ (casts are ignored) *)
+val nb_lam : constr -> int
+
+(* similar to [nb_lam], but gives the number of products instead *)
+val nb_prod : constr -> int
+
+(* flattens application lists *)
+val collapse_appl : constr -> constr
+
+
+(* Removes recursively the casts around a term i.e.
+   [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
+val strip_outer_cast : constr -> constr
+
+(* Apply a function letting Casted types in place *)
+val under_casts : (constr -> constr) -> constr -> constr
+
+(*s Occur checks *)
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+val closed0 : constr -> bool
+
+(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
+val noccurn : int -> constr -> bool
+
+(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+  for n <= p < n+m *)
+val noccur_between : int -> int -> constr -> bool
+
+(* Checking function for terms containing existential- or
+   meta-variables.  The function [noccur_with_meta] considers only
+   meta-variable applied to some terms (intented to be its local
+   context) (for existential variables, it is necessarily the case) *)
+val noccur_with_meta : int -> int -> constr -> bool
+
+(*s Relocation and substitution *)
+
+(* [exliftn el c] lifts [c] with lifting [el] *)
+val exliftn : Esubst.lift -> constr -> constr
+
+(* [liftn n k c] lifts by [n] indexes above [k] in [c] *)
+val liftn : int -> int -> constr -> constr
+
+(* [lift n c] lifts by [n] the positive indexes in [c] *)
+val lift : int -> constr -> constr
+
+(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
+    accordingly indexes in [a1],...,[an] *)
+val substnl : constr list -> int -> constr -> constr
+val substl : constr list -> constr -> constr
+val subst1 : constr -> constr -> constr
+
+val substl_decl : constr list -> named_declaration -> named_declaration
+val subst1_decl : constr -> named_declaration -> named_declaration
+
+val replace_vars : (identifier * constr) list -> constr -> constr
+val subst_var : identifier -> constr -> constr
+
+(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+   if two names are identical, the one of least indice is keeped *)
+val subst_vars : identifier list -> constr -> constr
+(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+   if two names are identical, the one of least indice is keeped *)
+val substn_vars : int -> identifier list -> constr -> constr
+
+
+(* [subst_mps sub c] performs the substitution [sub] on all kernel
+   names appearing in [c] *)
+val subst_mps : substitution -> constr -> constr
+
+
+(*s Functionals working on the immediate subterm of a construction *)
+
+(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
+
+(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val map_constr : (constr -> constr) -> constr -> constr
+
+(* [map_constr_with_binders 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; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val map_constr_with_binders :
+  ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val iter_constr : (constr -> unit) -> constr -> unit
+
+(* [iter_constr_with_binders g f n c] iters [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; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val iter_constr_with_binders :
+  ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
+   name and Cases annotations are not taken into account *)
+
+val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
+
+(*********************************************************************)
+
+val hcons_constr:
+  (kernel_name -> kernel_name) *
+  (dir_path -> dir_path) *
+  (name -> name) *
+  (identifier -> identifier) *
+  (string -> string) 
+  ->
+    (constr -> constr) *
+    (types -> types)
+
+val hcons1_constr : constr -> constr
+val hcons1_types : types -> types
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
new file mode 100644
index 00000000..5347583f
--- /dev/null
+++ b/kernel/term_typing.ml
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  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: term_typing.ml,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Sign
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Type_errors
+open Indtypes
+open Typeops
+
+let constrain_type env j cst1 = function
+  | None -> j.uj_type, cst1
+  | Some t -> 
+      let (tj,cst2) = infer_type env t in
+      let cst3 =
+	try conv_leq env j.uj_type tj.utj_val
+	with NotConvertible -> error_actual_type env j tj.utj_val in
+      let typ = 
+        if t = tj.utj_val then t else
+          (error "Kernel built a type different from its input\n";
+           flush stdout; tj.utj_val) in
+      typ, Constraint.union (Constraint.union cst1 cst2) cst3
+
+
+let translate_local_def env (b,topt) =
+  let (j,cst) = infer env b in
+  let (typ,cst) = constrain_type env j cst topt in
+    (j.uj_val,typ,cst)
+
+let translate_local_assum env t =
+  let (j,cst) = infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+    (t,cst)
+
+(*
+
+(* Same as push_named, but check that the variable is not already
+   there. Should *not* be done in Environ because tactics add temporary
+   hypothesis many many times, and the check performed here would
+   cost too much. *)
+let safe_push_named (id,_,_ as d) env =
+  let _ =
+    try
+      let _ = lookup_named id env in 
+      error ("identifier "^string_of_id id^" already defined")
+    with Not_found -> () in
+  push_named d env
+
+let push_named_def = push_rel_or_named_def safe_push_named
+let push_rel_def = push_rel_or_named_def push_rel
+
+let push_rel_or_named_assum push (id,t) env =
+  let (j,cst) = safe_infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+  let env' = add_constraints cst env in
+  let env'' = push (id,None,t) env' in
+  (cst,env'')
+
+let push_named_assum = push_rel_or_named_assum push_named
+let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env)
+
+let push_rels_with_univ vars env =
+  List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars
+*)
+
+
+(* Insertion of constants and parameters in environment. *)
+
+let infer_declaration env dcl =
+  match dcl with
+  | DefinitionEntry c ->
+      let (j,cst) = infer env c.const_entry_body in
+      let (typ,cst) = constrain_type env j cst c.const_entry_type in
+      Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque
+  | ParameterEntry t ->
+      let (j,cst) = infer env t in
+      None, Typeops.assumption_of_judgment env j, cst, false
+
+let build_constant_declaration env (body,typ,cst,op) =
+  let ids = match body with 
+    | None -> global_vars_set env typ
+    | Some b ->
+        Idset.union 
+	  (global_vars_set env (Declarations.force b)) 
+	  (global_vars_set env typ) 
+  in
+  let hyps = keep_hyps env ids in
+    { const_body = body;
+      const_type = typ;
+      const_hyps = hyps;
+      const_constraints = cst;
+      const_opaque = op }
+
+(*s Global and local constant declaration. *)
+
+let translate_constant env ce =
+  build_constant_declaration env (infer_declaration env ce)
+
+let translate_recipe env r = 
+  build_constant_declaration env (Cooking.cook_constant env r)
+
+(* Insertion of inductive types. *)
+
+let translate_mind env mie = check_inductive env mie 
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
new file mode 100644
index 00000000..67d479ba
--- /dev/null
+++ b/kernel/term_typing.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  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: term_typing.mli,v 1.2.8.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Univ
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Typeops
+(*i*)
+
+val translate_local_def : env -> constr * types option -> 
+  constr * types * Univ.constraints
+
+val translate_local_assum : env -> types ->
+  types * Univ.constraints
+
+val translate_constant : env -> constant_entry -> constant_body
+
+val translate_mind : 
+  env -> mutual_inductive_entry -> mutual_inductive_body
+
+val translate_recipe : 
+  env -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
new file mode 100644
index 00000000..c3d4726f
--- /dev/null
+++ b/kernel/type_errors.ml
@@ -0,0 +1,114 @@
+(************************************************************************)
+(*  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: type_errors.ml,v 1.31.2.1 2004/07/16 19:30:27 herbelin Exp $ *)
+
+open Names
+open Term
+open Sign
+open Environ
+open Reduction
+
+(* Type errors. *)
+
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * types list * constr * unsafe_judgment
+      * (constr * constr * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * types) * unsafe_judgment
+  | ActualType of unsafe_judgment * types
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * types array
+
+exception TypeError of env * type_error
+
+let nfj {uj_val=c;uj_type=ct} =
+  {uj_val=c;uj_type=nf_betaiota ct}
+
+let error_unbound_rel env n =
+  raise (TypeError (env, UnboundRel n))
+
+let error_unbound_var env v =
+  raise (TypeError (env, UnboundVar v))
+
+let error_not_type env j =
+  raise (TypeError (env, NotAType j))
+
+let error_assumption env j =
+  raise (TypeError (env, BadAssumption j))
+
+let error_reference_variables env id =
+  raise (TypeError (env, ReferenceVariables id))
+
+let error_elim_arity env ind aritylst c pj okinds = 
+  raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
+
+let error_case_not_inductive env j = 
+  raise (TypeError (env, CaseNotInductive j))
+
+let error_number_branches env cj expn =
+  raise (TypeError (env, NumberBranches (nfj cj,expn)))
+
+let error_ill_formed_branch env c i actty expty =
+  raise (TypeError (env,
+    IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
+
+let error_generalization env nvar c =
+  raise (TypeError (env, Generalization (nvar,c)))
+
+let error_actual_type env j expty =
+  raise (TypeError (env, ActualType (j,expty)))
+
+let error_cant_apply_not_functional env rator randl =
+  raise (TypeError (env, CantApplyNonFunctional (rator,randl)))
+
+let error_cant_apply_bad_type env t rator randl =
+  raise(TypeError (env, CantApplyBadType (t,rator,randl)))
+
+let error_ill_formed_rec_body env why lna i =
+  raise (TypeError (env, IllFormedRecBody (why,lna,i)))
+
+let error_ill_typed_rec_body env i lna vdefj vargs =
+  raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
+
+
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
new file mode 100644
index 00000000..2e8a7138
--- /dev/null
+++ b/kernel/type_errors.mli
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  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: type_errors.mli,v 1.36.2.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+(*i*)
+
+(* Type errors. \label{typeerrors} *)
+
+(*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
+    notation i*)
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * types list * constr * unsafe_judgment
+      * (constr * constr * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * types) * unsafe_judgment
+  | ActualType of unsafe_judgment * types
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * types array
+
+exception TypeError of env * type_error
+
+val error_unbound_rel : env -> int -> 'a
+
+val error_unbound_var : env -> variable -> 'a
+
+val error_not_type : env -> unsafe_judgment -> 'a
+
+val error_assumption : env -> unsafe_judgment -> 'a
+ 
+val error_reference_variables : env -> constr -> 'a
+
+val error_elim_arity : 
+  env -> inductive -> types list -> constr 
+    -> unsafe_judgment -> (constr * constr * arity_error) option -> 'a
+
+val error_case_not_inductive : env -> unsafe_judgment -> 'a
+
+val error_number_branches : env -> unsafe_judgment -> int -> 'a
+
+val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
+
+val error_generalization : env -> name * types -> unsafe_judgment -> 'a
+
+val error_actual_type : env -> unsafe_judgment -> types -> 'a
+
+val error_cant_apply_not_functional : 
+  env -> unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_cant_apply_bad_type : 
+  env -> int * constr * constr -> 
+      unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_ill_formed_rec_body :
+  env -> guard_error -> name array -> int -> 'a
+
+val error_ill_typed_rec_body  :
+  env -> int -> name array -> unsafe_judgment array -> types array -> 'a
+
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
new file mode 100644
index 00000000..66b2e24d
--- /dev/null
+++ b/kernel/typeops.ml
@@ -0,0 +1,489 @@
+(************************************************************************)
+(*  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: typeops.ml,v 1.89.2.1 2004/07/16 19:30:28 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Sign
+open Environ
+open Entries
+open Reduction
+open Inductive
+open Type_errors
+
+
+(* This should be a type (a priori without intension to be an assumption) *)
+let type_judgment env j =
+  match kind_of_term(whd_betadeltaiota env (body_of_type j.uj_type)) with
+    | Sort s -> {utj_val = j.uj_val; utj_type = s }
+    | _ -> error_not_type env j
+
+(* This should be a type intended to be assumed. The error message is *)
+(* not as useful as for [type_judgment]. *)
+let assumption_of_judgment env j =
+  try (type_judgment env j).utj_val
+  with TypeError _ ->
+    error_assumption env j
+
+(*
+let aojkey = Profile.declare_profile "assumption_of_judgment";;
+let assumption_of_judgment env j
+  = Profile.profile2 aojkey assumption_of_judgment env j;;
+*)
+
+(************************************************)
+(* Incremental typing rules: builds a typing judgement given the *)
+(* judgements for the subterms. *)
+
+(*s Type of sorts *)
+
+(* Prop and Set *)
+
+let judge_of_prop =
+  { uj_val = body_of_type mkProp;
+    uj_type = mkSort type_0 }
+
+let judge_of_set =
+  { uj_val = body_of_type mkSet;
+    uj_type = mkSort type_0 }
+
+let judge_of_prop_contents = function
+  | Null -> judge_of_prop
+  | Pos -> judge_of_set
+
+(* Type of Type(i). *)
+
+let judge_of_type u =
+  let uu = super u in
+  { uj_val = body_of_type (mkType u);
+    uj_type = mkType uu }
+
+(*s Type of a de Bruijn index. *)
+	  
+let judge_of_relative env n = 
+  try
+    let (_,_,typ) = lookup_rel n env in
+    { uj_val  = mkRel n;
+      uj_type = type_app (lift n) typ }
+  with Not_found -> 
+    error_unbound_rel env n
+
+(*
+let relativekey = Profile.declare_profile "judge_of_relative";;
+let judge_of_relative env n =
+  Profile.profile2 relativekey judge_of_relative env n;;
+*)
+
+(* Type of variables *)
+let judge_of_variable env id =
+  try
+    let (_,_,ty) = lookup_named id env in
+    make_judge (mkVar id) ty
+  with Not_found -> 
+    error_unbound_var env id
+
+(* Management of context of variables. *)
+
+(* Checks if a context of variable can be instanciated by the
+   variables of the current env *)
+(* TODO: check order? *)
+let rec check_hyps_inclusion env sign =
+  let env_sign = named_context env in
+  Sign.fold_named_context
+    (fun (id,_,ty1) () ->
+      let (_,_,ty2) = Sign.lookup_named id env_sign in
+      if not (eq_constr ty2 ty1) then
+        error "types do not match")
+    sign
+    ~init:()
+
+
+let check_args env c hyps =
+  let hyps' = named_context env in
+  try check_hyps_inclusion env hyps
+  with UserError _ | Not_found ->
+    error_reference_variables env c
+
+
+(* Checks if the given context of variables [hyps] is included in the
+   current context of [env]. *)
+(*
+let check_hyps id env hyps =
+  let hyps' = named_context env in
+  if not (hyps_inclusion env hyps hyps') then
+    error_reference_variables env id
+*)
+(* Instantiation of terms on real arguments. *)
+
+(* Type of constants *)
+let judge_of_constant env cst =
+  let constr = mkConst cst in
+  let _ =
+    let ce = lookup_constant cst env in
+    check_args env constr ce.const_hyps in 
+  make_judge constr (constant_type env cst)
+
+(*
+let tockey = Profile.declare_profile "type_of_constant";;
+let type_of_constant env c 
+  = Profile.profile3 tockey type_of_constant env c;;
+*)
+
+(* Type of a lambda-abstraction. *)
+
+(* [judge_of_abstraction env name var j] implements the rule
+
+ env, name:typ |- j.uj_val:j.uj_type     env, |- (name:typ)j.uj_type : s
+ -----------------------------------------------------------------------
+          env |- [name:typ]j.uj_val : (name:typ)j.uj_type
+
+  Since all products are defined in the Calculus of Inductive Constructions
+  and no upper constraint exists on the sort $s$, we don't need to compute $s$
+*)
+
+let judge_of_abstraction env name var j =
+  { uj_val = mkLambda (name, var.utj_val, j.uj_val);
+    uj_type = mkProd (name, var.utj_val, j.uj_type) }
+
+(* Type of let-in. *)
+
+let judge_of_letin env name defj typj j =
+  { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ;
+    uj_type = type_app (subst1 defj.uj_val) j.uj_type }
+
+(* Type of an application. *)
+
+let judge_of_apply env funj argjv =
+  let rec apply_rec n typ cst = function
+    | [] -> 
+	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
+          uj_type = typ },
+	cst
+    | hj::restjl ->
+        (match kind_of_term (whd_betadeltaiota env typ) with
+          | Prod (_,c1,c2) ->
+	      (try 
+		let c = conv_leq env hj.uj_type c1 in
+		let cst' = Constraint.union cst c in
+		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
+	      with NotConvertible -> 
+		error_cant_apply_bad_type env
+		  (n,c1, hj.uj_type)
+		  funj argjv)
+
+          | _ ->
+	      error_cant_apply_not_functional env funj argjv)
+  in 
+  apply_rec 1
+    funj.uj_type
+    Constraint.empty
+    (Array.to_list argjv)
+
+(* Type of product *)
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *) 
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        if engagement env = Some ImpredicativeSet then
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        else
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          domsort
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop _,  Type _)  -> rangsort
+    (* Product rule (Type_i,Type_i,Type_i) *) 
+    | (Type u1, Type u2) -> Type (sup u1 u2)
+
+(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
+
+    env |- typ1:s1       env, name:typ1 |- typ2 : s2
+    -------------------------------------------------------------------------
+         s' >= (s1,s2), env |- (name:typ)j.uj_val : s'
+
+  where j.uj_type is convertible to a sort s2
+*)
+let judge_of_product env name t1 t2 =
+  let s = sort_of_product env t1.utj_type t2.utj_type in
+  { uj_val = mkProd (name, t1.utj_val, t2.utj_val);
+    uj_type = mkSort s }
+
+(* Type of a type cast *)
+
+(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
+
+    env |- c:typ1    env |- typ2:s    env |- typ1 <= typ2
+    ---------------------------------------------------------------------
+         env |- c:typ2
+*)
+
+let judge_of_cast env cj tj =
+  let expected_type = tj.utj_val in
+  try 
+    let cst = conv_leq env cj.uj_type expected_type in
+    { uj_val = mkCast (j_val cj, expected_type);
+      uj_type = expected_type },
+    cst
+  with NotConvertible ->
+    error_actual_type env cj expected_type
+
+(* Inductive types. *)
+
+let judge_of_inductive env i =
+  let constr = mkInd i in
+  let _ =
+    let (kn,_) = i in
+    let mib = lookup_mind kn env in
+    check_args env constr mib.mind_hyps in 
+  make_judge constr (type_of_inductive env i)
+
+(*
+let toikey = Profile.declare_profile "judge_of_inductive";;
+let judge_of_inductive env i
+  = Profile.profile2 toikey judge_of_inductive env i;;
+*)
+
+(* Constructors. *)
+
+let judge_of_constructor env c =
+  let constr = mkConstruct c in
+  let _ =
+    let ((kn,_),_) = c in
+    let mib = lookup_mind kn env in
+    check_args env constr mib.mind_hyps in 
+  make_judge constr (type_of_constructor env c)
+
+(*
+let tockey = Profile.declare_profile "judge_of_constructor";;
+let judge_of_constructor env cstr
+  = Profile.profile2 tockey judge_of_constructor env cstr;;
+*)
+
+(* Case. *)
+
+let check_branch_types env cj (lft,explft) = 
+  try conv_leq_vecti env lft explft
+  with
+      NotConvertibleVect i ->
+        error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i)
+    | Invalid_argument _ ->
+        error_number_branches env cj (Array.length explft)
+
+let judge_of_case env ci pj cj lfj =
+  let indspec =
+    try find_rectype env cj.uj_type
+    with Not_found -> error_case_not_inductive env cj in
+  let _ = check_case_info env (fst indspec) ci in
+  let (bty,rslty,univ) =
+    type_case_branches env indspec pj cj.uj_val in
+  let (_,kind) = dest_arity env pj.uj_type in
+  let lft = Array.map j_type lfj in
+  let univ' = check_branch_types env cj (lft,bty) in
+  ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
+                       Array.map j_val lfj);
+     uj_type = rslty },
+  Constraint.union univ univ')
+
+(*
+let tocasekey = Profile.declare_profile "judge_of_case";;
+let judge_of_case env ci pj cj lfj
+  = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;;
+*)
+
+(* Fixpoints. *)
+
+(* Checks the type of a general (co)fixpoint, i.e. without checking *)
+(* the specific guard condition. *)
+
+let type_fixpoint env lna lar vdefj =
+  let lt = Array.length vdefj in
+  assert (Array.length lar = lt);
+  try
+    conv_leq_vecti env
+      (Array.map (fun j -> body_of_type j.uj_type) vdefj)
+      (Array.map (fun ty -> lift lt ty) lar)
+  with NotConvertibleVect i ->
+    error_ill_typed_rec_body env i lna vdefj lar
+
+(************************************************************************)
+(************************************************************************)
+
+(* This combinator adds the universe constraints both in the local
+   graph and in the universes of the environment. This is to ensure
+   that the infered local graph is satisfiable. *)
+let univ_combinator (cst,univ) (j,c') =
+  (j,(Constraint.union cst c', merge_constraints c' univ))
+
+(* The typing machine. *)
+    (* ATTENTION : faudra faire le typage du contexte des Const,
+    Ind et Constructsi un jour cela devient des constructions
+    arbitraires et non plus des variables *)
+let rec execute env cstr cu =
+  match kind_of_term cstr with
+    (* Atomic terms *)
+    | Sort (Prop c) -> 
+	(judge_of_prop_contents c, cu)
+
+    | Sort (Type u) ->
+	(judge_of_type u, cu)
+
+    | Rel n -> 
+	(judge_of_relative env n, cu)
+
+    | Var id -> 
+	(judge_of_variable env id, cu)
+
+    | Const c ->
+        (judge_of_constant env c, cu)
+
+    (* Lambda calculus operators *)
+    | App (f,args) ->
+	let (j,cu1) = execute env f cu in
+        let (jl,cu2) = execute_array env args cu1 in
+	univ_combinator cu2
+	  (judge_of_apply env j jl)
+	    
+    | Lambda (name,c1,c2) -> 
+        let (varj,cu1) = execute_type env c1 cu in
+	let env1 = push_rel (name,None,varj.utj_val) env in
+        let (j',cu2) = execute env1 c2 cu1 in 
+        (judge_of_abstraction env name varj j', cu2)
+	  
+    | Prod (name,c1,c2) ->
+        let (varj,cu1) = execute_type env c1 cu in
+	let env1 = push_rel (name,None,varj.utj_val) env in
+        let (varj',cu2) = execute_type env1 c2 cu1 in
+	(judge_of_product env name varj varj', cu2)
+
+    | LetIn (name,c1,c2,c3) ->
+        let (j1,cu1) = execute env c1 cu in
+        let (j2,cu2) = execute_type env c2 cu1 in
+        let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 j2) in
+        let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+        let (j',cu4) = execute env1 c3 cu3 in
+        (judge_of_letin env name j1 j2 j', cu4)
+	  
+    | Cast (c,t) ->
+        let (cj,cu1) = execute env c cu in
+        let (tj,cu2) = execute_type env t cu1 in
+	univ_combinator cu2
+          (judge_of_cast env cj tj)
+
+    (* Inductive types *)
+    | Ind ind ->
+	(judge_of_inductive env ind, cu)
+
+    | Construct c -> 
+	(judge_of_constructor env c, cu)
+
+    | Case (ci,p,c,lf) ->
+        let (cj,cu1) = execute env c cu in
+        let (pj,cu2) = execute env p cu1 in
+        let (lfj,cu3) = execute_array env lf cu2 in
+        univ_combinator cu3
+          (judge_of_case env ci pj cj lfj)
+  
+    | Fix ((vn,i as vni),recdef) ->
+        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
+        let fix = (vni,recdef') in
+        check_fix env fix;
+	(make_judge (mkFix fix) fix_ty, cu1)
+	  
+    | CoFix (i,recdef) ->
+        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
+        let cofix = (i,recdef') in
+        check_cofix env cofix;
+	(make_judge (mkCoFix cofix) fix_ty, cu1)
+
+    (* Partial proofs: unsupported by the kernel *)
+    | Meta _ ->
+	anomaly "the kernel does not support metavariables"
+
+    | Evar _ ->
+	anomaly "the kernel does not support existential variables"
+
+and execute_type env constr cu = 
+  let (j,cu1) = execute env constr cu in
+  (type_judgment env j, cu1)
+	  
+and execute_recdef env (names,lar,vdef) i cu =
+  let (larj,cu1) = execute_array env lar cu in
+  let lara = Array.map (assumption_of_judgment env) larj in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let (vdefj,cu2) = execute_array env1 vdef cu1 in
+  let vdefv = Array.map j_val vdefj in
+  let cst = type_fixpoint env1 names lara vdefj in
+  univ_combinator cu2
+    ((lara.(i),(names,lara,vdefv)),cst)
+
+and execute_array env v cu =
+  let (jl,cu1) = execute_list env (Array.to_list v) cu in
+  (Array.of_list jl, cu1)
+
+and execute_list env l cu =
+  match l with
+  | [] -> 
+      ([], cu)
+  | c::r -> 
+      let (j,cu1) = execute env c cu in 
+      let (jr,cu2) = execute_list env r cu1 in
+      (j::jr, cu2)
+
+(* Derived functions *)
+let infer env constr =
+  let (j,(cst,_)) =
+    execute env constr (Constraint.empty, universes env) in
+  let j = if j.uj_val = constr then { j with uj_val = constr } else
+    (error "Kernel built a body different from its input\n";
+     flush stdout; j) in
+  (j, cst)
+
+let infer_type env constr =
+  let (j,(cst,_)) =
+    execute_type env constr (Constraint.empty, universes env) in
+  (j, cst)
+
+let infer_v env cv =
+  let (jv,(cst,_)) =
+    execute_array env cv (Constraint.empty, universes env) in
+  (jv, cst)
+ 
+(* Typing of several terms. *)
+
+let infer_local_decl env id = function
+  | LocalDef c -> 
+      let (j,cst) = infer env c in
+      (Name id, Some j.uj_val, j.uj_type), cst
+  | LocalAssum c ->
+      let (j,cst) = infer env c in
+      (Name id, None, assumption_of_judgment env j), cst
+
+let infer_local_decls env decls =
+  let rec inferec env = function
+  | (id, d) :: l -> 
+      let env, l, cst1 = inferec env l in
+      let d, cst2 = infer_local_decl env id d in
+      push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2
+  | [] -> env, empty_rel_context, Constraint.empty in
+  inferec env decls
+
+(* Exported typing functions *)
+
+let typing env c = 
+  let (j,cst) = infer env c in
+  let _ = add_constraints cst env in
+  j
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
new file mode 100644
index 00000000..ffe9d861
--- /dev/null
+++ b/kernel/typeops.mli
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  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: typeops.mli,v 1.44.8.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Environ
+open Entries
+(*i*)
+
+(*s Typing functions (not yet tagged as safe) *)
+
+val infer      : env -> constr       -> unsafe_judgment * constraints
+val infer_v    : env -> constr array -> unsafe_judgment array * constraints
+val infer_type : env -> types        -> unsafe_type_judgment * constraints
+
+val infer_local_decls :
+  env -> (identifier * local_entry) list
+    -> env * Sign.rel_context * constraints
+
+(*s Basic operations of the typing machine. *)
+
+(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j]
+   returns the type $c$, checking that $t$ is a sort. *)
+
+val assumption_of_judgment :  env -> unsafe_judgment -> types
+val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
+
+(*s Type of sorts. *)
+val judge_of_prop_contents : contents -> unsafe_judgment
+val judge_of_type          : universe -> unsafe_judgment
+
+(*s Type of a bound variable. *)
+val judge_of_relative : env -> int -> unsafe_judgment
+
+(*s Type of variables *)
+val judge_of_variable : env -> variable -> unsafe_judgment
+
+(*s type of a constant *)
+val judge_of_constant : env -> constant -> unsafe_judgment
+
+(*s Type of application. *)
+val judge_of_apply : 
+  env -> unsafe_judgment -> unsafe_judgment array
+    -> unsafe_judgment * constraints
+
+(*s Type of an abstraction. *)
+val judge_of_abstraction : 
+  env -> name -> unsafe_type_judgment -> unsafe_judgment 
+    -> unsafe_judgment
+
+(*s Type of a product. *)
+val judge_of_product :
+  env -> name -> unsafe_type_judgment -> unsafe_type_judgment 
+    -> unsafe_judgment
+
+(* s Type of a let in. *)
+val judge_of_letin :
+  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment 
+    -> unsafe_judgment
+
+(*s Type of a cast. *)
+val judge_of_cast :
+  env -> unsafe_judgment -> unsafe_type_judgment
+    -> unsafe_judgment * constraints
+
+(*s Inductive types. *)
+
+val judge_of_inductive : env -> inductive -> unsafe_judgment
+
+val judge_of_constructor : env -> constructor -> unsafe_judgment
+
+(*s Type of Cases. *)
+val judge_of_case : env -> case_info
+  -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
+    -> unsafe_judgment * constraints
+
+(* Typecheck general fixpoint (not checking guard conditions) *)
+val type_fixpoint : env -> name array -> types array 
+    -> unsafe_judgment array -> constraints
+
+(* Kernel safe typing but applicable to partial proofs *)
+val typing : env -> constr -> unsafe_judgment
+
diff --git a/kernel/univ.ml b/kernel/univ.ml
new file mode 100644
index 00000000..d46609c8
--- /dev/null
+++ b/kernel/univ.ml
@@ -0,0 +1,469 @@
+(************************************************************************)
+(*  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: univ.ml,v 1.17.10.1 2004/07/16 19:30:28 herbelin Exp $ *)
+
+(* Universes are stratified by a partial ordering $\ge$.
+   Let $\~{}$ be the associated equivalence. We also have a strict ordering
+   $>$ between equivalence classes, and we maintain that $>$ is acyclic,
+   and contained in $\ge$ in the sense that $[U]>[V]$ implies $U\ge V$.
+
+   At every moment, we have a finite number of universes, and we
+   maintain the ordering in the presence of assertions $U>V$ and $U\ge V$.
+
+   The equivalence $\~{}$ is represented by a tree structure, as in the
+   union-find algorithm. The assertions $>$ and $\ge$ are represented by
+   adjacency lists *)
+
+open Pp
+open Util
+
+type universe_level =
+    { u_mod : Names.dir_path;
+      u_num : int }
+
+type universe =
+  | Variable of universe_level
+  | Max of universe_level list * universe_level list
+  
+module UniverseOrdered = struct
+  type t = universe_level
+  let compare = Pervasives.compare
+end
+
+let string_of_univ_level u =
+  Names.string_of_dirpath u.u_mod^"."^string_of_int u.u_num
+
+let make_univ (m,n) = Variable { u_mod=m; u_num=n }
+
+let string_of_univ = function
+  | Variable u -> string_of_univ_level u
+  | Max (gel,gtl) -> 
+      "max("^
+      (String.concat ","
+	 ((List.map string_of_univ_level gel)@
+	  (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")"
+
+let pr_uni_level u = str (string_of_univ_level u)
+
+let pr_uni = function
+  | Variable u -> 
+      pr_uni_level u
+  | Max (gel,gtl) ->
+      str "max(" ++ 
+      prlist_with_sep pr_coma pr_uni_level gel ++
+      if gel <> [] & gtl <> [] then pr_coma () else mt () ++
+      prlist_with_sep pr_coma
+	(fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++
+      str ")"
+
+(* Returns a fresh universe, juste above u. Does not create new universes
+   for Type_0 (the sort of Prop and Set).
+   Used to type the sort u. *)
+let super = function
+  | Variable u -> 
+      Max ([],[u])
+  | Max _ ->
+      anomaly ("Cannot take the successor of a non variable universes:\n"^
+       "you are probably typing a type already known to be the type\n"^
+       "of a user-provided term; if you really need this, please report")
+
+(* returns the least upper bound of universes u and v. If they are not
+   constrained, then a new universe is created.
+   Used to type the products. *)
+let sup u v = 
+  match u,v with
+    | Variable u, Variable v -> Max ((if u = v then [u] else [u;v]),[])
+    | Variable u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
+    | Max (gel,gtl), Variable v -> Max (list_add_set v gel,gtl)
+    | Max (gel,gtl), Max (gel',gtl') ->
+	Max (list_union gel gel',list_union gtl gtl')
+
+(* Comparison on this type is pointer equality *)
+type canonical_arc =
+    { univ: universe_level; gt: universe_level list; ge: universe_level list }
+
+let terminal u = {univ=u; gt=[]; ge=[]}
+
+(* A universe is either an alias for another one, or a canonical one,
+   for which we know the universes that are smaller *)
+type univ_entry =
+    Canonical of canonical_arc
+  | Equiv of universe_level * universe_level
+
+module UniverseMap = Map.Make(UniverseOrdered)
+
+type universes = univ_entry UniverseMap.t
+		   
+let enter_equiv_arc u v g =
+  UniverseMap.add u (Equiv(u,v)) g
+
+let enter_arc ca g =
+  UniverseMap.add ca.univ (Canonical ca) g
+
+let declare_univ u g =
+  if not (UniverseMap.mem u g) then
+    enter_arc (terminal u) g
+  else
+    g
+
+(* When typing Prop and Set, there is no constraint on the level,
+   hence the definition of prop_univ *)
+
+let initial_universes = UniverseMap.empty
+let prop_univ = Max ([],[])
+
+(* Every universe has a unique canonical arc representative *)
+
+(* repr : universes -> universe -> canonical_arc *)
+(* canonical representative : we follow the Equiv links *)
+let repr g u = 
+  let rec repr_rec u =
+    let a =
+      try UniverseMap.find u g
+      with Not_found -> anomalylabstrm "Univ.repr"
+	  (str"Universe " ++ pr_uni_level u ++ str" undefined") 
+    in
+    match a with 
+      | Equiv(_,v) -> repr_rec v
+      | Canonical arc -> arc
+  in
+  repr_rec u
+
+let can g = List.map (repr g)
+
+(* transitive closure : we follow the Greater links *)
+
+(* collect : canonical_arc -> canonical_arc list * canonical_arc list *)
+(* collect u = (V,W) iff V={v canonical | u>v} W={w canonical | u>=w}-V *)
+(* i.e. collect does the transitive closure of what is known about u *)
+let collect g arcu = 
+  let rec coll_rec gt ge = function
+    | [],[] -> (gt, list_subtractq ge gt)
+    | arcv::gt', ge' ->
+	if List.memq arcv gt then 
+	  coll_rec gt ge (gt',ge')
+	else
+          coll_rec (arcv::gt) ge ((can g (arcv.gt@arcv.ge))@gt',ge')
+    | [], arcw::ge' -> 
+	if (List.memq arcw gt) or (List.memq arcw ge) then 
+	  coll_rec gt ge ([],ge')
+	else
+          coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge')
+  in 
+  coll_rec [] [] ([],[arcu])
+
+(* reprgeq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu>=arcc with arcv#arcu *)
+let reprgeq g arcu =
+  let rec searchrec w = function
+    | [] -> w
+    | v :: vl ->
+	let arcv = repr g v in
+        if List.memq arcv w || arcu==arcv then 
+	  searchrec w vl
+        else 
+	  searchrec (arcv :: w) vl
+  in 
+  searchrec [] arcu.ge
+
+
+(* between : universe -> canonical_arc -> canonical_arc list *)
+(* between u v = {w|u>=w>=v, w canonical}          *)     
+(* between is the most costly operation *)
+
+let between g u arcv = 
+  (* good are all w | u >= w >= v  *)
+  (* bad are all w | u >= w ~>= v *)
+    (* find good and bad nodes in {w | u >= w} *)
+    (* explore b u = (b or "u is good") *)
+  let rec explore ((good, bad, b) as input) arcu =
+    if List.memq arcu good then
+      (good, bad, true) (* b or true *)
+    else if List.memq arcu bad then
+      input    (* (good, bad, b or false) *)
+    else 
+      let childs = reprgeq g arcu in 
+	(* are any children of u good ? *)
+      let good, bad, b_childs = 
+	List.fold_left explore (good, bad, false) childs 
+      in
+	if b_childs then
+	  arcu::good, bad, true (* b or true *)
+	else 
+	  good, arcu::bad, b    (* b or false *)
+  in
+  let good,_,_ = explore ([arcv],[],false) (repr g u) in
+    good
+      
+(* We assume  compare(u,v) = GE with v canonical (see compare below).
+   In this case List.hd(between g u v) = repr u
+   Otherwise, between g u v = [] 
+ *)
+
+
+type order = EQ | GT | GE | NGE
+
+(* compare : universe -> universe -> order *)
+let compare g u v = 
+  let arcu = repr g u 
+  and arcv = repr g v in
+  if arcu==arcv then 
+    EQ
+  else 
+    let (gt,geq) = collect g arcu in
+    if List.memq arcv gt then 
+      GT
+    else if List.memq arcv geq then 
+      GE
+    else 
+      NGE
+
+(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
+                compare(u,v) = GT or GE => compare(v,u) = NGE
+                compare(u,v) = NGE => compare(v,u) = NGE or GE or GT
+
+   Adding u>=v is consistent iff compare(v,u) # GT 
+    and then it is redundant iff compare(u,v) # NGE
+   Adding u>v is consistent iff compare(v,u) = NGE 
+    and then it is redundant iff compare(u,v) = GT *)
+
+
+(* setgt : universe -> universe -> unit *)
+(* forces u > v *)
+let setgt g u v =
+  let arcu = repr g u in
+  enter_arc {arcu with gt=v::arcu.gt} g
+
+(* checks that non-redondant *)
+let setgt_if g u v = match compare g u v with
+  | GT -> g
+  | _ -> setgt g u v
+
+(* setgeq : universe -> universe -> unit *)
+(* forces u >= v *)
+let setgeq g u v =
+  let arcu = repr g u in
+  enter_arc {arcu with ge=v::arcu.ge} g
+
+
+(* checks that non-redondant *)
+let setgeq_if g u v = match compare g u v with
+  | NGE -> setgeq g u v
+  | _ -> g
+
+(* merge : universe -> universe -> unit *)
+(* we assume  compare(u,v) = GE *)
+(* merge u v  forces u ~ v with repr u as canonical repr *)
+let merge g u v =
+  match between g u (repr g v) with
+    | arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
+                 (* redirected to it *)
+	let redirect (g,w,w') arcv =
+ 	  let g' = enter_equiv_arc arcv.univ arcu.univ g in
+ 	  (g',list_unionq arcv.gt w,arcv.ge@w') 
+	in
+	let (g',w,w') = List.fold_left redirect (g,[],[]) v in
+	let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' w in
+	let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' w' in
+	g'''
+    | [] -> anomaly "Univ.between"
+
+(* merge_disc : universe -> universe -> unit *)
+(* we assume  compare(u,v) = compare(v,u) = NGE *)
+(* merge_disc u v  forces u ~ v with repr u as canonical repr *)
+let merge_disc g u v =
+  let arcu = repr g u in
+  let arcv = repr g v in
+  let g' = enter_equiv_arc arcv.univ arcu.univ g in
+  let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' arcv.gt in
+  let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' arcv.ge in
+  g'''
+
+(* Universe inconsistency: error raised when trying to enforce a relation
+   that would create a cycle in the graph of universes. *)
+
+exception UniverseInconsistency
+
+let error_inconsistency () = raise UniverseInconsistency
+
+(* enforcegeq : universe -> universe -> unit *)
+(* enforcegeq u v will force u>=v if possible, will fail otherwise *)
+let enforce_univ_geq u v g =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  match compare g u v with
+    | NGE -> 
+	(match compare g v u with
+           | GT -> error_inconsistency()
+           | GE -> merge g v u
+           | NGE -> setgeq g u v
+           | EQ -> anomaly "Univ.compare")
+    | _ -> g
+
+(* enforceq : universe -> universe -> unit *)
+(* enforceq u v will force u=v if possible, will fail otherwise *)
+let enforce_univ_eq u v g =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  match compare g u v with
+    | EQ -> g
+    | GT -> error_inconsistency()
+    | GE -> merge g u v
+    | NGE -> 
+	(match compare g v u with
+           | GT -> error_inconsistency()
+           | GE -> merge g v u
+           | NGE -> merge_disc g u v
+           | EQ -> anomaly "Univ.compare")
+
+(* enforcegt u v will force u>v if possible, will fail otherwise *)
+let enforce_univ_gt u v g =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  match compare g u v with
+    | GT -> g
+    | GE -> setgt g u v
+    | EQ -> error_inconsistency()
+    | NGE -> 
+	(match compare g v u with
+           | NGE -> setgt g u v
+           | _ -> error_inconsistency())
+
+(*
+let enforce_univ_relation g = function 
+  | Equiv (u,v) -> enforce_univ_eq u v g
+  | Canonical {univ=u; gt=gt; ge=ge} ->
+      let g' = List.fold_right (enforce_univ_gt u) gt g in
+      List.fold_right (enforce_univ_geq u) ge g'
+*)
+
+(* Merging 2 universe graphs *)
+(*
+let merge_universes sp u1 u2 =
+  UniverseMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2
+*)
+
+
+(* Constraints and sets of consrtaints. *)
+
+type constraint_type = Gt | Geq | Eq
+
+type univ_constraint = universe_level * constraint_type * universe_level
+
+let enforce_constraint cst g =
+  match cst with
+    | (u,Gt,v) -> enforce_univ_gt u v g
+    | (u,Geq,v) -> enforce_univ_geq u v g
+    | (u,Eq,v) -> enforce_univ_eq u v g
+
+
+module Constraint = Set.Make(
+  struct 
+    type t = univ_constraint 
+    let compare = Pervasives.compare 
+  end)
+		      
+type constraints = Constraint.t
+
+type constraint_function = 
+    universe -> universe -> constraints -> constraints
+
+let enforce_gt u v c = Constraint.add (u,Gt,v) c
+
+let enforce_geq u v c =
+  match u with
+    | Variable u -> (match v with
+	| Variable v -> Constraint.add (u,Geq,v) c
+	| Max (l1, l2) ->
+	    let d = List.fold_right (fun v -> Constraint.add (u,Geq,v)) l1 c in
+	    List.fold_right (fun v -> Constraint.add (u,Gt,v)) l2 d) 
+    | Max _ -> anomaly "A universe bound can only be a variable"
+
+let enforce_eq u v c =
+  match (u,v) with
+    | Variable u, Variable v -> Constraint.add (u,Eq,v) c
+    | _ -> anomaly "A universe comparison can only happen between variables"
+
+let merge_constraints c g =
+  Constraint.fold enforce_constraint c g
+
+(* Pretty-printing *)
+
+let num_universes g =
+  UniverseMap.fold (fun _ _ -> succ) g 0
+
+let num_edges g =
+  let reln_len = function
+    | Equiv _ -> 1
+    | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge
+  in
+  UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0
+    
+let pr_arc = function 
+  | Canonical {univ=u; gt=[]; ge=[]} ->
+      mt ()
+  | Canonical {univ=u; gt=gt; ge=ge} ->
+      pr_uni_level u ++ str " " ++
+      v 0
+        (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++
+         prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++
+      fnl ()
+  | Equiv (u,v) -> 
+      pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
+
+let pr_universes g =
+  let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in
+  prlist (function (_,a) -> pr_arc a) graph
+    
+
+(* Dumping constrains to a file *)
+
+let dump_universes output g = 
+  let dump_arc _ = function
+    | Canonical {univ=u; gt=gt; ge=ge} -> 
+	let u_str = string_of_univ_level u in
+	  List.iter 
+	    (fun v -> 
+	       Printf.fprintf output "%s > %s ;\n" u_str
+		 (string_of_univ_level v)) 
+	    gt;
+	  List.iter 
+	    (fun v -> 
+	       Printf.fprintf output "%s >= %s ;\n" u_str
+		 (string_of_univ_level v)) 
+	    ge
+    | Equiv (u,v) ->
+	Printf.fprintf output "%s = %s ;\n"
+	  (string_of_univ_level u) (string_of_univ_level v)
+  in
+    UniverseMap.iter dump_arc g 
+
+module Huniv =
+  Hashcons.Make(
+    struct
+      type t = universe
+      type u = Names.dir_path -> Names.dir_path
+      let hash_aux hdir u = { u with u_mod=hdir u.u_mod }
+      let hash_sub hdir = function
+	| Variable u -> Variable (hash_aux hdir u)
+	| Max (gel,gtl) ->
+	    Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
+      let equal u v =
+	match u, v with
+	  | Variable u, Variable v -> u == v
+	  | Max (gel,gtl), Max (gel',gtl') ->
+	      (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl')
+	  | _ -> false
+      let hash = Hashtbl.hash
+    end)
+
+let hcons1_univ u =
+  let _,hdir,_,_,_ = Names.hcons_names() in
+  Hashcons.simple_hcons Huniv.f hdir u
+
diff --git a/kernel/univ.mli b/kernel/univ.mli
new file mode 100644
index 00000000..e15971eb
--- /dev/null
+++ b/kernel/univ.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  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: univ.mli,v 1.21.14.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+
+(* Universes. *)
+
+type universe
+
+val prop_univ : universe
+val make_univ : Names.dir_path * int -> universe
+
+(* The type of a universe *)
+val super : universe -> universe
+(* The max of 2 universes *)
+val sup   : universe -> universe -> universe
+
+(*s Graphs of universes. *)
+
+type universes
+
+(* The empty graph of universes *)
+val initial_universes : universes
+
+(*s Constraints. *)
+
+module Constraint : Set.S
+
+type constraints = Constraint.t
+
+type constraint_function = universe -> universe -> constraints -> constraints
+
+val enforce_geq : constraint_function
+val enforce_eq : constraint_function
+
+(*s Merge of constraints in a universes graph. 
+  The function [merge_constraints] merges a set of constraints in a given
+  universes graph. It raises the exception [UniverseInconsistency] if the
+  constraints are not satisfiable. *)
+
+exception UniverseInconsistency
+
+val merge_constraints : constraints -> universes -> universes
+
+(*s Pretty-printing of universes. *)
+
+val pr_uni : universe -> Pp.std_ppcmds
+val pr_universes : universes -> Pp.std_ppcmds
+
+val string_of_univ : universe -> string
+
+(*s Dumping to a file *)
+
+val dump_universes : out_channel -> universes -> unit
+
+val hcons1_univ : universe -> universe