Imported Upstream version 8.4~betaupstream/8.4_beta

65 files changed, 3822 insertions, 3256 deletions

diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index a0cb4f1a..aab08d89 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -81,13 +81,6 @@ sp is a local copy of the global variable extern_sp. */
 #   define print_int(i) 
 #endif
 
-/* Wrapper pour caml_modify */ 	 
-#ifdef OCAML_307 	 
-#define CAML_MODIFY(a,b) modify(a,b) 	 
-#else 	 
-#define CAML_MODIFY(a,b) caml_modify(a,b) 	 
-#endif
-
 /* GC interface */
 #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
 #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
@@ -158,7 +151,7 @@ sp is a local copy of the global variable extern_sp. */
 #endif
 #endif
 
-/* For signal handling, we highjack some code from the caml runtime */
+/* For signal handling, we hijack some code from the caml runtime */
 
 extern intnat caml_signals_are_pending;
 extern intnat caml_pending_signals[];
@@ -671,7 +664,7 @@ value coq_interprete
 	  Field(accu, 0) = sp[0];
 	  *sp = accu;
 	  /* mise a jour du block accumulate */
-	  CAML_MODIFY(&Field(p[i], 1),*sp);
+	  caml_modify(&Field(p[i], 1),*sp);
 	  sp++;
 	}
 	pc += nfunc;
@@ -842,7 +835,7 @@ value coq_interprete
       
       Instruct(SETFIELD0){
 	print_instr("SETFIELD0");
-	CAML_MODIFY(&Field(accu, 0),*sp);
+	caml_modify(&Field(accu, 0),*sp);
 	sp++;
 	Next;
       }
@@ -850,7 +843,7 @@ value coq_interprete
       Instruct(SETFIELD1){
         int i, j, size, size_aux;
 	print_instr("SETFIELD1");
-	CAML_MODIFY(&Field(accu, 1),*sp);
+	caml_modify(&Field(accu, 1),*sp);
        	sp++;
 	Next; 
       }
@@ -868,9 +861,9 @@ value coq_interprete
 	    *sp = accu;
 	    Alloc_small(accu, 1, ATOM_COFIX_TAG);
 	    Field(accu, 0) = Field(Field(*sp, 1), 0);
-	    CAML_MODIFY(&Field(*sp, 1), accu);
+	    caml_modify(&Field(*sp, 1), accu);
 	    accu = *sp; sp++;
-            CAML_MODIFY(&Field(*sp, i), accu);
+            caml_modify(&Field(*sp, i), accu);
 	  }
 	}
 	sp++;
@@ -879,7 +872,7 @@ value coq_interprete
       
       Instruct(SETFIELD){
 	print_instr("SETFIELD");
-	CAML_MODIFY(&Field(accu, *pc),*sp);
+	caml_modify(&Field(accu, *pc),*sp);
 	sp++; pc++;
 	Next;
       }	
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 91342108..00f5eb3b 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -50,12 +50,6 @@ value coq_static_alloc(value size) /* ML */
   return (value) coq_stat_alloc((asize_t) Long_val(size));
 }
 
-value coq_static_free(value blk)  /* ML */
-{
-  coq_stat_free((void *) blk);
-  return Val_unit;
-}
-
 value accumulate_code(value unit) /* ML */
 {
   return (value) accumulate;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index c0093a49..79e4d0fe 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -49,7 +49,6 @@ extern code_t accumulate;
 /* functions over global environment */
 
 value coq_static_alloc(value size);  /* ML */
-value coq_static_free(value string); /* ML */
 
 value init_coq_vm(value unit); /* ML */
 value re_init_coq_vm(value unit); /* ML */
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
index 0a61ad79..86bee72e 100644
--- a/kernel/byterun/int64_emul.h
+++ b/kernel/byterun/int64_emul.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
 /* Software emulation of 64-bit integer arithmetic, for C compilers
    that do not support it.  */
 
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
index 4fc3c220..8a6a2664 100644
--- a/kernel/byterun/int64_native.h
+++ b/kernel/byterun/int64_native.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
 /* Wrapper macros around native 64-bit integer arithmetic,
    so that it has the same interface as the software emulation
    provided in int64_emul.h */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index f4d0bb2b..8854f854 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+   bytecode-based reduction machine, Oct 2004 *)
+(* Support for native arithmetics by Arnaud Spiwack, May 2007 *)
+
+(* This file defines the type of bytecode instructions *)
+
 open Names
 open Term
 
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index f4dc0b14..c5d483ac 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: cbytecodes.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
 open Names
 open Term
 
@@ -38,42 +48,43 @@ type instruction =
   | Kpush
   | Kpop of int
   | Kpush_retaddr of Label.t
-  | Kapply of int                       (*  number of arguments *)
-  | Kappterm of int * int               (* number of arguments, slot size *)
-  | Kreturn of int                      (* slot size *)
+  | Kapply of int                       (**  number of arguments *)
+  | Kappterm of int * int               (** number of arguments, slot size *)
+  | Kreturn of int                      (** slot size *)
   | Kjump
   | Krestart
-  | Kgrab of int                        (* number of arguments *)
-  | Kgrabrec of int                     (* rec arg *)
-  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | Kgrab of int                        (** number of arguments *)
+  | Kgrabrec of int                     (** rec arg *)
+  | Kclosure of Label.t * int           (** label, number of free variables *)
   | Kclosurerec of int * int * Label.t array * Label.t array
-                   (* nb fv, init, lbl types, lbl bodies *)
+                   (** nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
-                   (* nb fv, init, lbl types, lbl bodies *)
+                   (** nb fv, init, lbl types, lbl bodies *)
   | Kgetglobal of constant
   | Kconst of structured_constant
-  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeblock of int * tag             (** size, tag *)
   | Kmakeprod
   | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
-  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kswitch of Label.t array * Label.t array (** consts,blocks *)
   | Kpushfields of int
   | Kfield of int
   | Ksetfield of int
   | Kstop
   | Ksequence of bytecodes * bytecodes
-(* spiwack: instructions concerning integers *)
-  | Kbranch of Label.t                  (* jump to label, is it needed ? *)
-  | Kaddint31                           (* adds the int31 in the accu
+
+(** spiwack: instructions concerning integers *)
+  | Kbranch of Label.t                  (** jump to label, is it needed ? *)
+  | Kaddint31                           (** adds the int31 in the accu
                                            and the one ontop of the stack *)
-  | Kaddcint31                          (* makes the sum and keeps the carry *)
-  | Kaddcarrycint31                     (* sum +1, keeps the carry *)
-  | Ksubint31                           (* subtraction modulo *)
-  | Ksubcint31                          (* subtraction, keeps the carry *)
-  | Ksubcarrycint31                     (* subtraction -1, keeps the carry *)
-  | Kmulint31                           (* multiplication modulo *)
-  | Kmulcint31                          (* multiplication, result in two
+  | Kaddcint31                          (** makes the sum and keeps the carry *)
+  | Kaddcarrycint31                     (** sum +1, keeps the carry *)
+  | Ksubint31                           (** subtraction modulo *)
+  | Ksubcint31                          (** subtraction, keeps the carry *)
+  | Ksubcarrycint31                     (** subtraction -1, keeps the carry *)
+  | Kmulint31                           (** multiplication modulo *)
+  | Kmulcint31                          (** multiplication, result in two
 					   int31, for exact computation *)
-  | Kdiv21int31                         (* divides a double size integer
+  | Kdiv21int31                         (** divides a double size integer
                                            (represented by an int31 in the
 					   accumulator and one on the top of
 					   the stack) by an int31. The result
@@ -81,23 +92,23 @@ type instruction =
 					   rest.
 					   If the divisor is 0, it returns
 					   0. *)
-  | Kdivint31                           (* euclidian division (returns a pair
+  | Kdivint31                           (** euclidian division (returns a pair
 					   quotient,rest) *)
-  | Kaddmuldivint31                     (* generic operation for shifting and
+  | Kaddmuldivint31                     (** generic operation for shifting and
 					   cycling. Takes 3 int31 i j and s,
 					   and returns x*2^s+y/(2^(31-s) *)
-  | Kcompareint31                        (* unsigned comparison of int31
+  | Kcompareint31                        (** unsigned comparison of int31
 					   cf COMPAREINT31 in
 					   kernel/byterun/coq_interp.c
 					   for more info *)
-  | Khead0int31                         (* Give the numbers of 0 in head of a in31*)
-  | Ktail0int31                         (* Give the numbers of 0 in tail of a in31
+  | Khead0int31                         (** Give the numbers of 0 in head of a in31*)
+  | Ktail0int31                         (** Give the numbers of 0 in tail of a in31
                                            ie low bits *)
-  | Kisconst of Label.t                 (* conditional jump *)
-  | Kareconst of int*Label.t            (* conditional jump *)
-  | Kcompint31                          (* dynamic compilation of int31 *)
-  | Kdecompint31                        (* dynamix decompilation of int31 *)
-(* /spiwack *)
+  | Kisconst of Label.t                 (** conditional jump *)
+  | Kareconst of int*Label.t            (** conditional jump *)
+  | Kcompint31                          (** dynamic compilation of int31 *)
+  | Kdecompint31                        (** dynamix decompilation of int31 
+   /spiwack *)
 
 
 and bytecodes = instruction list
@@ -107,25 +118,25 @@ type fv_elem = FVnamed of identifier | FVrel of int
 type fv = fv_elem array
 
 
-(* spiwack: this exception is expected to be raised by function expecting
+(** spiwack: this exception is expected to be raised by function expecting
             closed terms. *)
 exception NotClosed
 
 (*spiwack: both type have been moved from Cbytegen because I needed then
   for the retroknowledge *)
 type vm_env = {
-    size : int;              (* longueur de la liste [n] *)
-    fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
+    size : int;              (** longueur de la liste [n] *)
+    fv_rev : fv_elem list    (** [fvn; ... ;fv1] *)
   }
 
 
 type comp_env = {
-    nb_stack : int;              (* nbre de variables sur la pile          *)
-    in_stack : int list;         (* position dans la pile                  *)
-    nb_rec : int;                (* nbre de fonctions mutuellement         *)
-                                 (* recursives =  nbr                      *)
-    pos_rec  : instruction list; (* instruction d'acces pour les variables *)
-                                 (*  de point fix ou de cofix              *)
+    nb_stack : int;              (** nbre de variables sur la pile          *)
+    in_stack : int list;         (** position dans la pile                  *)
+    nb_rec : int;                (** nbre de fonctions mutuellement         *)
+                                 (** recursives =  nbr                      *)
+    pos_rec  : instruction list; (** instruction d'acces pour les variables *)
+                                 (**  de point fix ou de cofix              *)
     offset : int;
     in_env : vm_env ref
   }
@@ -140,7 +151,7 @@ type block =
   | Bstrconst of structured_constant
   | Bmakeblock of int * block array
   | Bconstruct_app of int * int * int * block array
-                  (* tag , nparams, arity *)
+                  (** tag , nparams, arity *)
   | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
-                (* compilation function (see get_vm_constant_dynamic_info in
+                (** compilation function (see get_vm_constant_dynamic_info in
                    retroknowledge.mli for more info) , argument array  *)
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 0578c7b4..8da06f43 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+   machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
 open Util
 open Names
 open Cbytecodes
@@ -339,7 +351,7 @@ let rec str_const c =
   | App(f,args) ->
       begin
 	match kind_of_term f with
-	| Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *)
+	| Construct((kn,j),i) -> 
             begin
 	    let oib = lookup_mind kn !global_env in
 	    let oip = oib.mind_packets.(j) in
@@ -409,7 +421,7 @@ let rec str_const c =
 	| _ -> Bconstr c
       end
   | Ind ind -> Bstrconst (Const_ind ind)
-  | Construct ((kn,j),i) ->  (*arnaud: Construct ((kn,j),i as cstr) ->  *)
+  | Construct ((kn,j),i) ->  
       begin
       (* spiwack: tries first to apply the run-time compilation
            behavior of the constructor, as in 2/ above *)
@@ -668,19 +680,6 @@ and compile_str_cst reloc sc sz cont =
 (* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
 and compile_const =
-(*arnaud:  let code_construct kn cont =
-     let f_cont =
-         let else_lbl = Label.create () in
-         Kareconst(2, else_lbl):: Kacc 0:: Kpop 1::
-          Kaddint31:: Kreturn 0:: Klabel else_lbl::
-         (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*)
-          Kgetglobal (get_allias !global_env kn)::
-          Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *)
-     in
-     let lbl = Label.create () in
-     fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
-     Kclosure(lbl, 0)::cont
-  in *)
   fun reloc-> fun  kn -> fun args -> fun sz -> fun cont ->
   let nargs = Array.length args in
   (* spiwack: checks if there is a specific way to compile the constant
@@ -715,18 +714,11 @@ let compile env c =
   Format.print_flush();  *)
   init_code,!fun_code, Array.of_list fv
 
-let compile_constant_body env body opaque boxed =
-  if opaque then BCconstant
-  else match body with
-  | None -> BCconstant
-  | Some sb ->
+let compile_constant_body env = function
+  | Undef _ | OpaqueDef _ -> BCconstant
+  | Def sb ->
       let body = Declarations.force sb in
-      if boxed then
-	let res = compile env body in
-	let to_patch = to_memory res in
-	BCdefined(true, to_patch)
-      else
-	match kind_of_term body with
+      match kind_of_term body with
 	| Const kn' ->
 	    (* we use the canonical name of the constant*)
 	    let con= constant_of_kn (canonical_con kn') in
@@ -734,8 +726,11 @@ let compile_constant_body env body opaque boxed =
 	| _ ->
 	    let res = compile env body in
 	    let to_patch = to_memory res in
-	    BCdefined (false, to_patch)
+	    BCdefined to_patch
+
+(* Shortcut of the previous function used during module strengthening *)
 
+let compile_alias kn = BCallias (constant_of_kn (canonical_con kn))
 
 (* spiwack: additional function which allow different part of compilation of the
       31-bit integers *)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index f33fd6cb..d0bfd46c 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -7,20 +7,21 @@ open Pre_env
 
 
 val compile : env -> constr -> bytecodes * bytecodes * fv
-                              (* init, fun, fv *)
+                              (** init, fun, fv *)
 
-val compile_constant_body :
-    env -> constr_substituted option -> bool -> bool -> body_code
-                                 (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> body_code
 
+(** Shortcut of the previous function used during module strengthening *)
 
-(* spiwack: this function contains the information needed to perform
+val compile_alias : constant -> body_code
+
+(** spiwack: this function contains the information needed to perform
             the static compilation of int31 (trying and obtaining
             a 31-bit integer in processor representation at compile time) *)
 val compile_structured_int31 : bool -> constr array ->
                                structured_constant
 
-(* this function contains the information needed to perform
+(** this function contains the information needed to perform
         the dynamic compilation of int31 (trying and obtaining a
         31-bit integer in processor representation at runtime when
         it failed at compile time *)
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 0b4df194..1f00a70e 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+   machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
 open Names
 open Term
 open Cbytecodes
@@ -321,12 +333,12 @@ let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
 type body_code =
-  | BCdefined of bool * to_patch
+  | BCdefined of to_patch
   | BCallias of constant
   | BCconstant
 
 let subst_body_code s = function
-  | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp)
+  | BCdefined tp -> BCdefined (subst_to_patch s tp)
   | BCallias kn -> BCallias (fst (subst_con s kn))
   | BCconstant -> BCconstant
 
@@ -338,11 +350,6 @@ let force = force subst_body_code
 
 let subst_to_patch_subst = subst_substituted
 
-let is_boxed tps =
-  match force tps with
-  | BCdefined(b,_) -> b
-  | _ -> false
-
 let repr_body_code = repr_substituted
 
 let to_memory (init_code, fun_code, fv) =
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 384146d2..287c3930 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -7,6 +7,7 @@ type reloc_info =
   | Reloc_getglobal of constant
 
 type patch = reloc_info * int
+
 (* A virer *)
 val subst_patch : Mod_subst.substitution -> patch -> patch
 
@@ -23,7 +24,7 @@ type to_patch = emitcodes * (patch list) * fv
 val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
 
 type body_code =
-  | BCdefined of bool*to_patch
+  | BCdefined of to_patch
   | BCallias of constant
   | BCconstant
 
@@ -34,12 +35,10 @@ val from_val : body_code -> to_patch_substituted
 
 val force : to_patch_substituted -> body_code
 
-val is_boxed : to_patch_substituted -> bool
-
 val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
 
 val repr_body_code :
   to_patch_substituted -> Mod_subst.substitution list option * body_code
 
 val to_memory : bytecodes * bytecodes * fv -> to_patch
-               (* init code, fun code, fv *)
+               (** init code, fun code, fv *)
diff --git a/kernel/closure.ml b/kernel/closure.ml
index bb68835e..143d6eb4 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -1,12 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras with Benjamin Werner's account to implement
+   a call-by-value conversion algorithm and a lazy reduction machine
+   with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Call-by-value machine moved to cbv.ml, Mar 01 *)
+(* Additional tools for module subtyping by Jacek Chrzaszcz, Aug 2002 *)
+(* Extension with closure optimization by Bruno Barras, Aug 2003 *)
+(* Support for evar reduction by Bruno Barras, Feb 2009 *)
+(* Miscellaneous other improvements by Bruno Barras, 1997-2009 *)
+
+(* This file implements a lazy reduction for the Calculus of Inductive
+   Constructions *)
 
 open Util
 open Pp
@@ -55,6 +66,9 @@ let with_stats c =
 let all_opaque = (Idpred.empty, Cpred.empty)
 let all_transparent = (Idpred.full, Cpred.full)
 
+let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
+
 module type RedFlagsSig = sig
   type reds
   type red_kind
@@ -70,7 +84,6 @@ module type RedFlagsSig = sig
   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
@@ -145,16 +158,6 @@ module RedFlags = (struct
     | 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) = Cpred.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
@@ -511,7 +514,7 @@ let optimise_closure env c =
     let (c',(_,s)) = compact_constr (0,[]) c 1 in
     let env' =
       Array.map (fun i -> clos_rel env i) (Array.of_list s) in
-    (subs_cons (env', ESID 0),c')
+    (subs_cons (env', subs_id 0),c')
 
 let mk_lambda env t =
   let (env,t) = optimise_closure env t in
@@ -644,7 +647,7 @@ let term_of_fconstr =
       | 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
+  term_of_fconstr_lift el_id
 
 
 
@@ -679,16 +682,6 @@ let fapp_stack (m,stk) = zip m stk
    (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
@@ -705,15 +698,14 @@ let strip_update_shift_app head stk =
 
 let get_nth_arg head n stk =
   assert (head.norm <> Red);
-  let rec strip_rec rstk h depth n = function
+  let rec strip_rec rstk h n = function
     | Zshift(k) as e :: s ->
-        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+        strip_rec (e::rstk) (lift_fconstr k h) n s
     | Zapp args::s' ->
         let q = Array.length args in
         if n >= q
         then
-          strip_rec (Zapp args::rstk)
-            {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
+          strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s'
         else
           let bef = Array.sub args 0 n in
           let aft = Array.sub args (n+1) (q-n-1) in
@@ -721,9 +713,9 @@ let get_nth_arg head n stk =
             List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
           (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) depth n s
+        strip_rec rstk (update m (h.norm,h.term)) n s
     | s -> (None, List.rev rstk @ s) in
-  strip_rec [] head 0 n stk
+  strip_rec [] head n stk
 
 (* Beta reduction: look for an applied argument in the stack.
    Since the encountered update marks are removed, h must be a whnf *)
@@ -746,6 +738,12 @@ let rec get_args n tys f e stk =
           get_args (n-na) etys f (subs_cons(l,e)) s
     | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
 
+(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
+let rec eta_expand_stack = function
+  | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+      e :: eta_expand_stack s
+  | [] ->
+      [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
 
 (* Iota reduction: extract the arguments to be passed to the Case
    branches *)
@@ -965,7 +963,7 @@ let whd_val info v =
 let norm_val info v =
   with_stats (lazy (kl info v))
 
-let inject = mk_clos (ESID 0)
+let inject = mk_clos (subs_id 0)
 
 let whd_stack infos m stk =
   let k = kni infos m stk in
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 9cfd9797..f4dc5db3 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -1,28 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Names
 open Term
 open Environ
 open Esubst
-(*i*)
 
-(* Flags for profiling reductions. *)
+(** 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
+(** {6 ... } *)
+(** 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 *)
@@ -32,12 +29,15 @@ val with_stats: 'a Lazy.t -> 'a
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
 
-(* Sets of reduction kinds. *)
+val is_transparent_variable : transparent_state -> variable -> bool
+val is_transparent_constant : transparent_state -> constant -> bool
+
+(** Sets of reduction kinds. *)
 module type RedFlagsSig = sig
   type reds
   type red_kind
 
-  (* The different kinds of reduction *)
+  (** The different kinds of reduction *)
   val fBETA : red_kind
   val fDELTA : red_kind
   val fIOTA : red_kind
@@ -45,26 +45,24 @@ module type RedFlagsSig = sig
   val fCONST : constant -> red_kind
   val fVAR : identifier -> red_kind
 
-  (* No reduction at all *)
+  (** No reduction at all *)
   val no_red : reds
 
-  (* Adds a reduction kind to a set *)
+  (** Adds a reduction kind to a set *)
   val red_add : reds -> red_kind -> reds
 
-  (* Removes a reduction kind to a set *)
+  (** Removes a reduction kind to a set *)
   val red_sub : reds -> red_kind -> reds
 
-  (* Adds a reduction kind to a set *)
+  (** 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] *)
+  (** 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 *)
+  (** 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
@@ -89,19 +87,19 @@ val create: ('a infos -> constr -> 'a) -> reds -> env ->
   (existential -> constr option) -> 'a infos
 val evar_value : 'a infos -> existential -> constr option
 
-(************************************************************************)
-(*s Lazy reduction. *)
+(***********************************************************************
+  s Lazy reduction. *)
 
-(* [fconstr] is the type of frozen constr *)
+(** [fconstr] is the type of frozen constr *)
 
 type fconstr
 
-(* [fconstr] can be accessed by using the function [fterm_of] and by
+(** [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 *)
+  | FAtom of constr (** Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
@@ -118,8 +116,8 @@ type fterm =
   | FCLOS of constr * fconstr subs
   | FLOCKED
 
-(************************************************************************)
-(*s A [stack] is a context of arguments, arguments are pushed by
+(***********************************************************************
+  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 *)
 
@@ -142,13 +140,15 @@ val stack_args_size : stack -> int
 val stack_tail : int -> stack -> stack
 val stack_nth : stack -> int -> fconstr
 val zip_term : (fconstr -> constr) -> constr -> stack -> constr
+val eta_expand_stack : stack -> stack
 
-(* To lazy reduce a constr, create a [clos_infos] with
+(** 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
-(* mk_atom: prevents a term from being evaluated *)
+
+(** mk_atom: prevents a term from being evaluated *)
 val mk_atom : constr -> fconstr
 
 val fterm_of : fconstr -> fterm
@@ -156,33 +156,33 @@ val term_of_fconstr : fconstr -> constr
 val destFLambda :
   (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
 
-(* Global and local constant cache *)
+(** Global and local constant cache *)
 type clos_infos
 val create_clos_infos :
   ?evars:(existential->constr option) -> reds -> env -> clos_infos
 
-(* Reduction function *)
+(** Reduction function *)
 
-(* [norm_val] is for strong normalization *)
+(** [norm_val] is for strong normalization *)
 val norm_val : clos_infos -> fconstr -> constr
 
-(* [whd_val] is for weak head normalization *)
+(** [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
+(** [whd_stack] performs weak head normalization in a given stack. It
    stops whenever a reduction is blocked. *)
 val whd_stack :
   clos_infos -> fconstr -> stack -> fconstr * stack
 
-(* Conversion auxiliary functions to do step by step normalisation *)
+(** Conversion auxiliary functions to do step by step normalisation *)
 
-(* [unfold_reference] unfolds references in a [fconstr] *)
+(** [unfold_reference] unfolds references in a [fconstr] *)
 val unfold_reference : clos_infos -> table_key -> fconstr option
 
 val eq_table_key : table_key -> table_key -> bool
 
-(************************************************************************)
-(*i This is for lazy debug *)
+(***********************************************************************
+  i This is for lazy debug *)
 
 val lift_fconstr      : int -> fconstr -> fconstr
 val lift_fconstr_vect : int -> fconstr array -> fconstr array
@@ -200,4 +200,4 @@ 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*)
+(** End of cbn debug section i*)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 3f6b77b0..92109258 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras as part of the rewriting of the conversion
+   algorithm, Nov 2001 *)
 
 open Names
 
@@ -55,12 +56,12 @@ let get_transp_state () =
 
 (* Unfold the first constant only if it is "more transparent" than the
    second one. In case of tie, expand the second one. *)
-let oracle_order k1 k2 =
+let oracle_order l2r k1 k2 =
   match get_strategy k1, get_strategy k2 with
     | Expand, _ -> true
     | Level n1, Opaque -> true
     | Level n1, Level n2 -> n1 < n2
-    | _ -> false (* expand k2 *)
+    | _ -> l2r (* use recommended default *)
 
 (* summary operations *)
 let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 9272dfe5..09ca4b92 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -1,22 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 
-(* Order on section paths for unfolding.
+(** 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 : 'a tableKey -> 'a tableKey -> bool
+val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
 
-(* Priority for the expansion of constant in the conversion test.
+(** Priority for the expansion of constant in the conversion test.
  * Higher levels means that the expansion is less prioritary.
  * (And Expand stands for -oo, and Opaque +oo.)
  * The default value (transparent constants) is [Level 0].
@@ -26,14 +24,14 @@ val transparent : level
 
 val get_strategy : 'a tableKey -> level
 
-(* Sets the level of a constant.
+(** Sets the level of a constant.
  * Level of RelKey constant cannot be set. *)
 val set_strategy : 'a tableKey -> level -> unit
 
 val get_transp_state : unit -> transparent_state
 
-(*****************************)
-(* Summary operations *)
+(****************************
+   Summary operations *)
 type oracle
 val init     : unit -> unit
 val freeze   : unit -> oracle
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index d35c011a..02330339 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jean-Christophe Filliâtre out of V6.3 file constants.ml
+   as part of the rebuilding of Coq around a purely functional
+   abstract type-checker, Nov 1999 *)
+
+(* This module implements kernel-level discharching of local
+   declarations over global constants and inductive types *)
 
 open Pp
 open Util
@@ -99,7 +104,7 @@ let expmod_constr modlist c =
 
   in
   if modlist = empty_modlist then c
-  else under_outer_cast nf_betaiota (substrec c)
+  else substrec c
 
 let abstract_constant_type =
    List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
@@ -112,16 +117,24 @@ type recipe = {
   d_abstract : named_context;
   d_modlist : work_list }
 
-let on_body f =
-  Option.map (fun c -> Declarations.from_val (f (Declarations.force c)))
+let on_body f = function
+  | Undef inl -> Undef inl
+  | Def cs -> Def (Declarations.from_val (f (Declarations.force cs)))
+  | OpaqueDef lc ->
+    OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc)))
+
+let constr_of_def = function
+  | Undef _ -> assert false
+  | Def cs -> Declarations.force cs
+  | OpaqueDef lc -> Declarations.force_opaque lc
 
 let cook_constant env r =
   let cb = r.d_from in
   let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
-  let body =
-    on_body (fun c ->
-      abstract_constant_body (expmod_constr r.d_modlist c) hyps)
-      cb.const_body in
+  let body = on_body
+    (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps)
+    cb.const_body
+  in
   let typ = match cb.const_type with
     | NonPolymorphicType t ->
 	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
@@ -129,8 +142,7 @@ let cook_constant env r =
     | PolymorphicArity (ctx,s) ->
 	let t = mkArity (ctx,Type s.poly_level) in
 	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	let j = make_judge (force (Option.get body)) typ in
+	let j = make_judge (constr_of_def body) typ in
 	Typeops.make_polymorphic_if_constant_for_ind env j
   in
-  let boxed = Cemitcodes.is_boxed cb.const_body_code in
-  (body, typ, cb.const_constraints, cb.const_opaque, boxed,false)
+  (body, typ, cb.const_constraints)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index df7e51f2..5f31ff8c 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Declarations
 open Environ
 open Univ
 
-(*s Cooking the constants. *)
+(** {6 Cooking the constants. } *)
 
 type work_list = identifier array Cmap.t * identifier array Mindmap.t
 
@@ -24,11 +22,10 @@ type recipe = {
   d_modlist : work_list }
 
 val cook_constant :
-  env -> recipe ->
-    constr_substituted option * constant_type * constraints * bool * bool
-  * bool
+  env -> recipe -> constant_def * constant_type * constraints
+
 
-(*s Utility functions used in module [Discharge]. *)
+(** {6 Utility functions used in module [Discharge]. } *)
 
 val expmod_constr : work_list -> constr -> constr
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2b3d3fac..e8b66d09 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+   bytecode-based reduction machine, Oct 2004 *)
+(* Bug fix #1419 by Jean-Marc Notin, Mar 2007 *)
+
+(* This file manages the table of global symbols for the bytecode machine *)
+
 open Names
 open Term
 open Vm
@@ -9,7 +23,6 @@ open Cbytegen
 
 
 external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
-external free_tcode : tcode -> unit = "coq_static_free"
 external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
 
 (*******************)
@@ -114,10 +127,9 @@ let rec slot_for_getglobal env kn =
 (*    Pp.msgnl(str"not yet evaluated");*)
     let pos =
       match Cemitcodes.force cb.const_body_code with
-      | BCdefined(boxed,(code,pl,fv)) ->
+      | BCdefined(code,pl,fv) ->
 	let v = eval_to_patch env (code,pl,fv) in
-  	if boxed then set_global_boxed kn v
-	else set_global v
+	set_global v
     | BCallias kn' -> slot_for_getglobal env kn'
     | BCconstant -> set_global (val_of_constant kn) in
 (*Pp.msgnl(str"value stored at: "++int pos);*)
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 894a33ef..8c1ad98b 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: csymtable.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
 open Names
 open Term
 open Pre_env
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index c18e6bb0..1a84b987 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -1,28 +1,35 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is a late renaming in May 2000 of constant.ml which
+   itself was made for V7.0 in Aug 1999 out of a dispatch by
+   Jean-Christophe Filliâtre of Chet Murthy's constants.ml in V5.10.5
+   into cooking.ml, declare.ml and constant.ml, ...; renaming done
+   because the new contents exceeded in extent what the name
+   suggested *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Declarations for the module systems added by Jacek Chrzaszcz, Aug 2002 *)
+(* Miscellaneous extensions, cleaning or restructurations by Bruno
+   Barras, Hugo Herbelin, Jean-Christophe Filliâtre, Pierre Letouzey *)
+
+(* This module defines the types of global declarations. This includes
+   global constants/axioms, mutual inductive definitions and the
+   module system *)
 
-(*i*)
 open Util
 open Names
 open Univ
 open Term
 open Sign
 open Mod_subst
-(*i*)
-
-(* This module defines the types of global declarations. This includes
-   global constants/axioms and mutual inductive definitions *)
 
 type engagement = ImpredicativeSet
 
-
 (*s Constants (internal representation) (Definition/Axiom) *)
 
 type polymorphic_arity = {
@@ -42,18 +49,61 @@ let force = force subst_mps
 
 let subst_constr_subst = subst_substituted
 
+(** Opaque proof terms are not loaded immediately, but are there
+    in a lazy form. Forcing this lazy may trigger some unmarshal of
+    the necessary structure. The ['a substituted] type isn't really great
+    here, so we store "manually" a substitution list, the younger one at top.
+*)
+
+type lazy_constr = constr_substituted Lazy.t * substitution list
+
+let force_lazy_constr (c,l) =
+  List.fold_right subst_constr_subst l (Lazy.force c)
+
+let lazy_constr_is_val (c,_) = Lazy.lazy_is_val c
+
+let make_lazy_constr c = (c, [])
+
+let force_opaque lc = force (force_lazy_constr lc)
+
+let opaque_from_val c = (Lazy.lazy_from_val (from_val c), [])
+
+let subst_lazy_constr sub (c,l) = (c,sub::l)
+
+(** Inlining level of parameters at functor applications.
+    None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
 type constant_body = {
     const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : Cemitcodes.to_patch_substituted;
-   (* const_type_code : Cemitcodes.to_patch; *)
-    const_constraints : constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : constraints }
 
-(*s Inductive types (internal representation with redundant
-    information). *)
+let body_of_constant cb = match cb.const_body with
+  | Undef _ -> None
+  | Def c -> Some c
+  | OpaqueDef lc -> Some (force_lazy_constr lc)
+
+let constant_has_body cb = match cb.const_body with
+  | Undef _ -> false
+  | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+  | OpaqueDef _ -> true
+  | Undef _ | Def _ -> false
+
+(* Substitutions of [constant_body] *)
 
 let subst_rel_declaration sub (id,copt,t as x) =
   let copt' = Option.smartmap (subst_mps sub) copt in
@@ -62,13 +112,78 @@ let subst_rel_declaration sub (id,copt,t as x) =
 
 let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
 
+(* TODO: these substitution functions could avoid duplicating things
+   when the substitution have preserved all the fields *)
+
+let subst_const_type sub arity =
+  if is_empty_subst sub then arity
+  else match arity with
+    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+
+let subst_const_def sub = function
+  | Undef inl -> Undef inl
+  | Def c -> Def (subst_constr_subst sub c)
+  | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
+
+let subst_const_body sub cb = {
+  const_hyps = (assert (cb.const_hyps=[]); []);
+  const_body = subst_const_def sub cb.const_body;
+  const_type = subst_const_type sub cb.const_type;
+  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+  const_constraints = cb.const_constraints}
+
+(* Hash-consing of [constant_body] *)
+
+let hcons_rel_decl ((n,oc,t) as d) =
+  let n' = hcons_name n
+  and oc' = Option.smartmap hcons_constr oc
+  and t' = hcons_types t
+  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
+
+let hcons_rel_context l = list_smartmap hcons_rel_decl l
+
+let hcons_polyarity ar =
+  { poly_param_levels =
+      list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels;
+    poly_level = hcons_univ ar.poly_level }
+
+let hcons_const_type = function
+  | NonPolymorphicType t ->
+    NonPolymorphicType (hcons_constr t)
+  | PolymorphicArity (ctx,s) ->
+    PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s)
+
+let hcons_const_def = function
+  | Undef inl -> Undef inl
+  | Def l_constr ->
+    let constr = force l_constr in
+    Def (from_val (hcons_constr constr))
+  | OpaqueDef lc ->
+    if lazy_constr_is_val lc then
+      let constr = force_opaque lc in
+      OpaqueDef (opaque_from_val (hcons_constr constr))
+    else OpaqueDef lc
+
+let hcons_const_body cb =
+  { cb with
+    const_body = hcons_const_def cb.const_body;
+    const_type = hcons_const_type cb.const_type;
+    const_constraints = hcons_constraints cb.const_constraints }
+
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 
 let subst_recarg sub r = match r with
-  | Norec | Mrec _  -> r
+  | Norec -> r
+  | Mrec (kn,i) -> let kn' = subst_ind sub kn in
+      if kn==kn' then r else Mrec (kn',i)
   | Imbr (kn,i) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
@@ -82,8 +197,14 @@ let mk_paths r recargs =
 
 let dest_recarg p = fst (Rtree.dest_node p)
 
+(* dest_subterms returns the sizes of each argument of each constructor of
+   an inductive object of size [p]. This should never be done for Norec,
+   because the number of sons does not correspond to the number of
+   constructors.
+ *)
 let dest_subterms p =
-  let (_,cstrs) = Rtree.dest_node p in
+  let (ra,cstrs) = Rtree.dest_node p in
+  assert (ra<>Norec);
   Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
 
 let recarg_length p j =
@@ -192,24 +313,7 @@ type mutual_inductive_body = {
 
   }
 
-let subst_arity sub arity =
-  if sub = empty_subst then arity
-  else match arity with
-    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
-    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
-	
-(* TODO: should be changed to non-coping after Term.subst_mps *)
-let subst_const_body sub cb = {
-  const_hyps = (assert (cb.const_hyps=[]); []);
-  const_body = Option.map (subst_constr_subst sub) cb.const_body;
-  const_type = subst_arity sub cb.const_type;
-  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
-  (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
-  const_constraints = cb.const_constraints;
-  const_opaque = cb.const_opaque;
-  const_inline = cb.const_inline} 
-  
-let subst_arity sub = function
+let subst_indarity sub = function
 | Monomorphic s ->
     Monomorphic {
       mind_user_arity = subst_mps sub s.mind_user_arity;
@@ -223,7 +327,7 @@ let subst_mind_packet sub mbp =
     mind_typename = mbp.mind_typename;
     mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
     mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
-    mind_arity = subst_arity sub mbp.mind_arity;
+    mind_arity = subst_indarity sub mbp.mind_arity;
     mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
     mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
@@ -233,7 +337,6 @@ let subst_mind_packet sub mbp =
     mind_nb_args = mbp.mind_nb_args;
     mind_reloc_tbl = mbp.mind_reloc_tbl }
 
-
 let subst_mind sub mib =
   { mind_record = mib.mind_record ;
     mind_finite = mib.mind_finite ;
@@ -246,6 +349,26 @@ let subst_mind sub mib =
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
     mind_constraints = mib.mind_constraints  }
 
+let hcons_indarity = function
+  | Monomorphic a ->
+    Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity;
+		  mind_sort = hcons_sorts a.mind_sort }
+  | Polymorphic a -> Polymorphic (hcons_polyarity a)
+
+let hcons_mind_packet oib =
+ { oib with
+   mind_typename = hcons_ident oib.mind_typename;
+   mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
+   mind_arity = hcons_indarity oib.mind_arity;
+   mind_consnames = array_smartmap hcons_ident oib.mind_consnames;
+   mind_user_lc = array_smartmap hcons_types oib.mind_user_lc;
+   mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc }
+
+let hcons_mind mib =
+  { mib with
+    mind_packets = array_smartmap hcons_mind_packet mib.mind_packets;
+    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
+    mind_constraints = hcons_constraints mib.mind_constraints }
 
 (*s Modules: signature component specifications, module types, and
   module declarations *)
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index db706a0c..5b800ede 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -1,30 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Cemitcodes
 open Sign
 open Mod_subst
-(*i*)
 
-(* This module defines the internal representation of global
+(** This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
    inductive definitions, modules and module types *)
 
 type engagement = ImpredicativeSet
 
-(**********************************************************************)
-(*s Representation of constants (Definition/Axiom)                    *)
+(** {6 Representation of constants (Definition/Axiom) } *)
 
 type polymorphic_arity = {
   poly_param_levels : universe option list;
@@ -40,24 +35,58 @@ type constr_substituted
 val from_val : constr -> constr_substituted
 val force : constr_substituted -> constr
 
+(** Opaque proof terms are not loaded immediately, but are there
+    in a lazy form. Forcing this lazy may trigger some unmarshal of
+    the necessary structure. *)
+
+type lazy_constr
+
+val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr
+val force_lazy_constr : lazy_constr -> constr_substituted
+val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr
+val lazy_constr_is_val : lazy_constr -> bool
+
+val force_opaque : lazy_constr -> constr
+val opaque_from_val : constr -> lazy_constr
+
+(** Inlining level of parameters at functor applications.
+    None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
 type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_hyps : section_context; (** New: younger hyp at top *)
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : to_patch_substituted;
-   (*i const_type_code : to_patch;i*)
-    const_constraints : constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : constraints }
 
+val subst_const_def : substitution -> constant_def -> constant_def
 val subst_const_body : substitution -> constant_body -> constant_body
 
-(**********************************************************************)
-(*s Representation of mutual inductive types in the kernel            *)
+(** Is there a actual body in const_body or const_body_opaque ? *)
+
+val constant_has_body : constant_body -> bool
+
+(** Accessing const_body_opaque or const_body *)
+
+val body_of_constant : constant_body -> constr_substituted option
+
+val is_opaque : constant_body -> bool
+
+(** {6 Representation of mutual inductive types in the kernel } *)
 
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 
 val subst_recarg : substitution -> recarg -> recarg
@@ -72,12 +101,12 @@ val recarg_length : wf_paths -> int -> int
 
 val subst_wf_paths : substitution -> wf_paths -> wf_paths
 
-(*
-\begin{verbatim}
+(**
+{v
    Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
    ...
    with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
-\end{verbatim}
+v}
 *)
 
 type monomorphic_inductive_arity = {
@@ -90,94 +119,72 @@ type inductive_arity =
 | Polymorphic of polymorphic_arity
 
 type one_inductive_body = {
+(** {8 Primitive datas } *)
 
-(* Primitive datas *)
+    mind_typename : identifier; (** Name of the type: [Ii] *)
 
- (* Name of the type: [Ii] *)
-    mind_typename : identifier;
+    mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
 
- (* Arity context of [Ii] with parameters: [forall params, Ui] *)
-    mind_arity_ctxt : rel_context;
+    mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *)
 
- (* Arity sort and original user arity if monomorphic *)
-    mind_arity : inductive_arity;
+    mind_consnames : identifier array; (** Names of the constructors: [cij] *)
 
- (* Names of the constructors: [cij] *)
-    mind_consnames : identifier array;
-
- (* Types of the constructors with parameters: [forall params, Tij],
-    where the Ik are replaced by de Bruijn index in the context
-    I1:forall params, U1 ..  In:forall params, Un *)
     mind_user_lc : types array;
+ (** Types of the constructors with parameters:  [forall params, Tij],
+     where the Ik are replaced by de Bruijn index in the
+     context I1:forall params, U1 ..  In:forall params, Un *)
 
-(* Derived datas *)
+(** {8 Derived datas } *)
 
- (* Number of expected real arguments of the type (no let, no params) *)
-    mind_nrealargs : int;
+    mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
 
- (* Length of realargs context (with let, no params) *)
-    mind_nrealargs_ctxt : int;
+    mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *)
 
- (* List of allowed elimination sorts *)
-    mind_kelim : sorts_family list;
+    mind_kelim : sorts_family list; (** List of allowed elimination sorts *)
 
- (* Head normalized constructor types so that their conclusion is atomic *)
-    mind_nf_lc : types array;
+    mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *)
 
- (* Length of the signature of the constructors (with let, w/o params)
-    (not used in the kernel) *)
     mind_consnrealdecls : int array;
+ (** Length of the signature of the constructors (with let, w/o params)
+    (not used in the kernel) *)
 
- (* Signature of recursive arguments in the constructors *)
-    mind_recargs : wf_paths;
+    mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *)
 
-(* Datas for bytecode compilation *)
+(** {8 Datas for bytecode compilation } *)
 
- (* number of constant constructor *)
-    mind_nb_constant : int;
+    mind_nb_constant : int; (** number of constant constructor *)
 
- (* number of no constant constructor *)
-    mind_nb_args : int;
+    mind_nb_args : int; (** number of no constant constructor *)
 
     mind_reloc_tbl :  Cbytecodes.reloc_table;
   }
 
 type mutual_inductive_body = {
 
-  (* The component of the mutual inductive block *)
-    mind_packets : one_inductive_body array;
+    mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
 
-  (* Whether the inductive type has been declared as a record *)
-    mind_record : bool;
+    mind_record : bool;  (** Whether the inductive type has been declared as a record *)
 
-  (* Whether the type is inductive or coinductive *)
-    mind_finite : bool;
+    mind_finite : bool;  (** Whether the type is inductive or coinductive *)
 
-  (* Number of types in the block *)
-    mind_ntypes : int;
+    mind_ntypes : int;  (** Number of types in the block *)
 
-  (* Section hypotheses on which the block depends *)
-    mind_hyps : section_context;
+    mind_hyps : section_context;  (** Section hypotheses on which the block depends *)
 
-  (* Number of expected parameters *)
-    mind_nparams : int;
+    mind_nparams : int;  (** Number of expected parameters *)
 
-  (* Number of recursively uniform (i.e. ordinary) parameters *)
-    mind_nparams_rec : int;
+    mind_nparams_rec : int;  (** Number of recursively uniform (i.e. ordinary) parameters *)
 
-  (* The context of parameters (includes let-in declaration) *)
-    mind_params_ctxt : rel_context;
+    mind_params_ctxt : rel_context;  (** The context of parameters (includes let-in declaration) *)
 
-  (* Universes constraints enforced by the inductive declaration *)
-    mind_constraints : constraints;
+    mind_constraints : constraints;  (** Universes constraints enforced by the inductive declaration *)
 
   }
 
 val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 
-(**********************************************************************)
-(*s Modules: signature component specifications, module types, and
-  module declarations *)
+(** {6 Modules: signature component specifications, module types, and
+  module declarations } *)
 
 type structure_field_body =
   | SFBconst of constant_body
@@ -199,29 +206,39 @@ and with_declaration_body =
   | With_definition_body of  identifier list * constant_body
 
 and module_body =
-    {  (*absolute path of the module*)
+    {  (** absolute path of the module *)
       mod_mp : module_path;
-      (* Implementation *)
+      (** Implementation *)
       mod_expr : struct_expr_body option; 
-      (* Signature *)
+      (** Signature *)
       mod_type : struct_expr_body;
-      (* algebraic structure expression is kept 
+      (** algebraic structure expression is kept 
 	 if it's relevant for extraction  *)
       mod_type_alg : struct_expr_body option; 
-      (* set of all constraint in the module  *)
+      (** set of all constraint in the module  *)
       mod_constraints : constraints;
-      (* quotiented set of equivalent constant and inductive name  *)
+      (** quotiented set of equivalent constant and inductive name  *)
       mod_delta : delta_resolver;
       mod_retroknowledge : Retroknowledge.action list}
       
 and module_type_body =
     { 
-      (*Path of the module type*)
+      (** Path of the module type *)
       typ_mp : module_path;
       typ_expr : struct_expr_body;
-      (* algebraic structure expression is kept 
+      (** algebraic structure expression is kept 
 	 if it's relevant for extraction  *)
       typ_expr_alg : struct_expr_body option ;
       typ_constraints : constraints;
-      (* quotiented set of equivalent constant and inductive name  *)
+      (** quotiented set of equivalent constant and inductive name  *)
       typ_delta :delta_resolver}
+
+
+(** Hash-consing *)
+
+(** Here, strictly speaking, we don't perform true hash-consing
+    of the structure, but simply hash-cons all inner constr
+    and other known elements *)
+
+val hcons_const_body : constant_body -> constant_body
+val hcons_mind : mutual_inductive_body -> mutual_inductive_body
diff --git a/kernel/entries.ml b/kernel/entries.ml
index 4ca21277..a4485fac 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Univ
@@ -58,12 +56,13 @@ type mutual_inductive_entry = {
 
 type definition_entry = {
   const_entry_body   : constr;
+  const_entry_secctx : section_context option;
   const_entry_type   : types option;
-  const_entry_opaque : bool;
-  const_entry_boxed  : bool}
+  const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
 
-(* type and the inlining flag *)
-type parameter_entry = types * bool
+type parameter_entry = section_context option * types * inline 
 
 type constant_entry =
   | DefinitionEntry of definition_entry
@@ -71,14 +70,7 @@ type constant_entry =
 
 (*s Modules *)
 
-
-type specification_entry = 
-    SPEconst of constant_entry
-  | SPEmind of mutual_inductive_entry
-  | SPEmodule of module_entry
-  | SPEmodtype of module_struct_entry
-      
-and module_struct_entry = 
+type module_struct_entry =
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/entries.mli b/kernel/entries.mli
index d71b48f6..b726d0ec 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -1,43 +1,38 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Sign
-(*i*)
 
-(* This module defines the entry types for global declarations. This
+(** 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 *)
+(** {6 Local entries } *)
 
 type local_entry =
   | LocalDef of constr
   | LocalAssum of constr
 
 
-(*s Declaration of inductive types. *)
+(** {6 Declaration of inductive types. } *)
 
-(* Assume the following definition in concrete syntax:
-\begin{verbatim}
-Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
+(** Assume the following definition in concrete syntax:
+{v 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]];
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. v}
+
+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]].
 *)
 
@@ -53,30 +48,25 @@ type mutual_inductive_entry = {
   mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
-(*s Constants (Definition/Axiom) *)
+(** {6 Constants (Definition/Axiom) } *)
 
 type definition_entry = {
   const_entry_body   : constr;
+  const_entry_secctx : section_context option;
   const_entry_type   : types option;
-  const_entry_opaque : bool;
-  const_entry_boxed  : bool }
+  const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
 
-type parameter_entry = types * bool  (*inline flag*)
+type parameter_entry = section_context option * types * inline 
 
 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_struct_entry
+(** {6 Modules } *)
 
-and module_struct_entry =
+type module_struct_entry =
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/environ.ml b/kernel/environ.ml
index e6fafce9..7a41e62c 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -1,12 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Author: Jean-Christophe Filliâtre as part of the rebuilding of Coq
+   around a purely functional abstract type-checker, Aug 1999 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Flag for predicativity of Set by Hugo Herbelin in Oct 2003 *)
+(* Support for virtual machine by Benjamin Grégoire in Oct 2004 *)
+(* Support for retroknowledge by Arnaud Spiwack in May 2007 *)
+(* Support for assumption dependencies by Arnaud Spiwack in May 2007 *)
+
+(* Miscellaneous maintenance by Bruno Barras, Hugo Herbelin, Jean-Marc
+   Notin, Matthieu Sozeau *)
+
+(* This file defines the type of environments on which the
+   type-checker works, together with simple related functions *)
 
 open Util
 open Names
@@ -97,7 +109,7 @@ let lookup_named id env = Sign.lookup_named id env.env_named_context
 let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
 
 let eq_named_context_val c1 c2 =
-   c1 == c2 || named_context_of_val c1 = named_context_of_val c2
+   c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
 
 (* A local const is evaluable if it is defined  *)
 
@@ -158,10 +170,10 @@ 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)
+    | Def l_body -> Declarations.force l_body
+    | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+    | Undef _ -> raise (NotEvaluableConst NoBody)
 
 let constant_opt_value env cst =
   try Some (constant_value env cst)
@@ -183,14 +195,9 @@ let add_mind kn mib env =
   { 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
+  if is_empty_constraint c then
     env
   else
     let s = env.env_stratification in
diff --git a/kernel/environ.mli b/kernel/environ.mli
index a7795136..42100e4e 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -1,26 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: environ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Declarations
 open Sign
-(*i*)
 
-(*s Unsafe environments. We define here a datatype for environments.
+(** 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:
+(** Environments have the following components:
    - a context for de Bruijn variables
    - a context for de Bruijn variables vm values
    - a context for section variables and goal assumptions
@@ -50,27 +46,27 @@ val named_context_val : env -> named_context_val
 
 val engagement    : env -> engagement option
 
-(* is the local context empty *)
+(** is the local context empty *)
 val empty_context : env -> bool
 
-(************************************************************************)
-(*s Context of de Bruijn variables ([rel_context]) *)
+(** {5 Context of de Bruijn variables ([rel_context]) } *)
+
 val nb_rel           : env -> int
 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 *)
+(** 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] *)
+(** {6 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) *)
+(** {5 Context of variables (section variables and goal assumptions) } *)
 
 val named_context_of_val : named_context_val -> named_context
 val named_vals_of_val : named_context_val -> Pre_env.named_vals
@@ -78,7 +74,7 @@ val val_of_named_context : named_context -> named_context_val
 val empty_named_context_val : named_context_val
 
 
-(* [map_named_val f ctxt] apply [f] to the body and the type of
+(** [map_named_val f ctxt] apply [f] to the body and the type of
    each declarations.
    *** /!\ ***   [f t] should be convertible with t *)
 val map_named_val :
@@ -90,8 +86,8 @@ val push_named_context_val  :
 
 
 
-(* Looks up in the context of local vars referred by names ([named_context]) *)
-(* raises [Not_found] if the identifier is not found *)
+(** 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 lookup_named_val : variable -> named_context_val -> named_declaration
@@ -99,34 +95,36 @@ val evaluable_named  : variable -> env -> bool
 val named_type : variable -> env -> types
 val named_body : variable -> env -> constr option
 
-(*s Recurrence on [named_context]: older declarations processed first *)
+(** {6 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 *)
+(** 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 *)
+(** This forgets named and rel contexts *)
 val reset_context : env -> env
-(* This forgets rel context and sets a new named context *)
+
+(** This forgets rel context and sets a new named context *)
 val reset_with_named_context : named_context_val -> env -> env
 
-(************************************************************************)
-(*s Global constants *)
-(*s Add entries to global environment *)
-val add_constant : constant -> constant_body -> env -> env
+(** {5 Global constants }
+  {6 Add entries to global environment } *)
 
-(* Looks up in the context of global constant names *)
-(* raises [Not_found] if the required path is not found *)
+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
+(** {6 ... } *)
+(** [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
 
@@ -134,44 +132,44 @@ val constant_value     : env -> constant -> constr
 val constant_type      : env -> constant -> constant_type
 val constant_opt_value : env -> constant -> constr option
 
-(************************************************************************)
-(*s Inductive types *)
+(** {5 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 *)
+(** 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 *)
+(** {5 Modules } *)
+
 val add_modtype : module_path -> module_type_body -> env -> env
 
-(* [shallow_add_module] does not add module components *)
+(** [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 : module_path -> env -> module_type_body
 
-(************************************************************************)
-(*s Universe constraints *)
-val set_universes   :   Univ.universes -> env -> env
+(** {5 Universe constraints } *)
+
 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 either
+(** {6 Sets of referred section variables }
+   [global_vars_set env c] returns the list of [id]'s occurring either
    directly as [Var id] in [c] or indirectly as a section variable
    dependent in a global reference occurring in [c] *)
+
 val global_vars_set : env -> constr -> Idset.t
-(* the constr must be a global reference *)
+
+(** the constr must be a global reference *)
 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
+(** {5 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. *)
 
@@ -188,23 +186,20 @@ type unsafe_type_judgment = {
   utj_type : sorts }
 
 
-(*s Compilation of global declaration *)
+(** {6 Compilation of global declaration } *)
 
-val compile_constant_body :
-    env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
-                                 (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> Cemitcodes.body_code
 
 exception Hyp_not_found
 
-(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
+(** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
    return [tail::(f head (id,_,_) (rev tail))::head].
    the value associated to id should not change *)
-
 val apply_to_hyp : named_context_val -> variable ->
   (named_context -> named_declaration -> named_context -> named_declaration) ->
     named_context_val
 
-(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
+(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
    [tail::(id,_,_)::head] and
    return [(g tail)::(f (id,_,_))::head]. *)
 val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
@@ -219,9 +214,10 @@ val insert_after_hyp : named_context_val -> variable ->
 val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
 
 
-(* spiwack: functions manipulating the retroknowledge *)
-open Retroknowledge
 
+open Retroknowledge
+(** functions manipulating the retroknowledge 
+    @author spiwack *)
 val retroknowledge : (retroknowledge->'a) -> env -> 'a
 
 val registered : env -> field -> bool
@@ -230,3 +226,4 @@ val unregister : env -> field -> env
 
 val register : env -> field -> Retroknowledge.entry -> env
 
+
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 82d19ec4..cbce04d6 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -1,12 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: esubst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras for Coq V7.0, Mar 2001 *)
+
+(* Support for explicit substitutions *)
 
 open Util
 
@@ -21,6 +23,8 @@ type lift =
   | ELLFT of int * lift  (* ELLFT(n,l)  == apply l to de Bruijn > n *)
                          (*                 i.e under n binders *)
 
+let el_id = ELID
+
 (* compose a relocation of magnitude n *)
 let rec el_shft_rec n = function
   | ELSHFT(el,k) -> el_shft_rec (k+n) el
@@ -67,6 +71,8 @@ type 'a subs =
  * Needn't be recursive if we always use these functions
  *)
 
+let subs_id i = ESID i
+
 let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
 
 let subs_liftn n = function
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 76c0d481..fe978261 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -1,61 +1,66 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: esubst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Explicit substitutions *)
 
-(*s Explicit substitutions of type ['a]. *)
-(*  - ESID(n)             = %n END   bounded identity
- *  - CONS([|t1..tn|],S)  = (S.t1...tn)    parallel substitution
- *       (beware of the order: indice 1 is substituted by tn)
- *  - SHIFT(n,S)          = (^n o S) terms in S are relocated with n vars
- *  - LIFT(n,S)           = (%n S) stands for ((^n o S).n...1)
+(** {6 Explicit substitutions } *)
+(** Explicit substitutions of type ['a]. 
+    - ESID(n)             = %n END   bounded identity
+    - CONS([|t1..tn|],S)  = (S.t1...tn)    parallel substitution
+        (beware of the order: indice 1 is substituted by tn)
+    - SHIFT(n,S)          = (^n o S) terms in S are relocated with n vars
+    - LIFT(n,S)           = (%n S) stands for ((^n o S).n...1)
          (corresponds to S crossing n binders) *)
-type 'a subs =
+type 'a subs = private
   | ESID of int
   | CONS of 'a array * 'a subs
   | SHIFT of int * 'a subs
   | LIFT of int * 'a subs
 
-(* Derived constructors granting basic invariants *)
+(** Derived constructors granting basic invariants *)
+val subs_id : int -> 'a subs
 val subs_cons: 'a array * '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
-(* [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *)
+
+(** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *)
 val subs_shift_cons: int * 'a subs * 'a array -> 'a subs
 
-(* [expand_rel k subs] expands de Bruijn [k] in the explicit substitution
- * [subs]. The result is either (Inl(lams,v)) when the variable is
- * substituted by value [v] under lams binders (i.e. v *has* to be
- * shifted by lams), or (Inr (k',p)) when the variable k is just relocated
- * as k'; p is None if the variable points inside subs and Some(k) if the
- * variable points k bindings beyond subs (cf argument of ESID).
- *)
+(** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution
+    [subs]. The result is either (Inl(lams,v)) when the variable is
+    substituted by value [v] under lams binders (i.e. v *has* to be
+    shifted by lams), or (Inr (k',p)) when the variable k is just relocated
+    as k'; p is None if the variable points inside subs and Some(k) if the
+    variable points k bindings beyond subs (cf argument of ESID).
+*)
 val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
 
-(* Tests whether a substitution behaves like the identity *)
+(** Tests whether a substitution behaves like the identity *)
 val is_subs_id: 'a subs -> bool
 
-(* Composition of substitutions: [comp mk_clos s1 s2] computes a
- * substitution equivalent to applying s2 then s1. Argument
- * mk_clos is used when a closure has to be created, i.e. when
- * s1 is applied on an element of s2.
- *)
+(** Composition of substitutions: [comp mk_clos s1 s2] computes a
+    substitution equivalent to applying s2 then s1. Argument
+    mk_clos is used when a closure has to be created, i.e. when
+    s1 is applied on an element of s2.
+*)
 val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
 
-(*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 =
+(** {6 Compact representation } *)
+(** 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 = private
   | ELID
   | ELSHFT of lift * int
   | ELLFT of int * lift
 
+val el_id : lift
 val el_shft : int -> lift -> lift
 val el_liftn : int -> lift -> lift
 val el_lift : lift -> lift
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 9b1ddc31..46e866a0 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -87,15 +85,6 @@ let mind_check_names mie =
   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
-
 (************************************************************************)
 (************************************************************************)
 
@@ -171,7 +160,7 @@ let inductive_levels arities inds =
    arity or type constructor; we do not to recompute universes constraints *)
 
 let constraint_list_union =
-  List.fold_left Constraint.union Constraint.empty
+  List.fold_left union_constraints empty_constraint
 
 let infer_constructor_packet env_ar_par params lc =
   (* type-check the constructors *)
@@ -208,7 +197,7 @@ let typecheck_inductive env mie =
 	    full_arity is used as argument or subject to cast, an
 	    upper universe will be generated *)
 	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
-	 let cst = Constraint.union cst cst2 in
+	 let cst = union_constraints cst cst2 in
 	 let id = ind.mind_entry_typename in
 	 let env_ar' =
            push_rel (Name id, None, full_arity)
@@ -237,7 +226,7 @@ let typecheck_inductive env mie =
 	   infer_constructor_packet env_ar_par params ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
 	 let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
-	 (ind'::inds, Constraint.union cst cst'))
+	 (ind'::inds, union_constraints cst cst'))
       mie.mind_entry_inds
       arity_list
       ([],cst) in
@@ -246,7 +235,8 @@ let typecheck_inductive env mie =
   let arities = Array.of_list arity_list in
   let param_ccls = List.fold_left (fun l (_,b,p) ->
     if b = None then
-      let _,c = dest_prod_assum env p in
+      (* Parameter contributes to polymorphism only if explicit Type *)
+      let c = strip_prod_assum p in
       (* Add Type levels to the ordered list of parameters contributing to *)
       (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
       match kind_of_term c with
@@ -373,6 +363,11 @@ if nmr = 0 then 0 else
           | _ -> k)
   in find 0 (n-1) (lpar,List.rev hyps)
 
+let lambda_implicit_lift n a =
+  let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in
+  let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
+  iterate lambda_implicit n (lift n a)
+
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
 let abstract_mind_lc env ntyps npars lc =
@@ -421,7 +416,7 @@ let array_min nmr a = if nmr = 0 then 0 else
 
 (* The recursive function that checks positivity and builds the list
    of recursive arguments *)
-let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
+let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
   let lparams = rel_context_length hyps in
   let nmr = rel_context_nhyps hyps in
   (* Checking the (strict) positivity of a constructor argument type [c] *)
@@ -466,8 +461,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
       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
-        failwith_non_pos_list n ntypes auxlargs;
+	failwith_non_pos_list n ntypes auxlargs;
       (* We do not deal with imbricated mutual inductive types *)
       let auxntyp = mib.mind_ntypes in
 	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
@@ -533,11 +529,11 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
   in
   let irecargs = Array.map snd irecargs_nmr
   and nmr' = array_min nmr irecargs_nmr
-  in (nmr', mk_paths (Mrec i) irecargs)
+  in (nmr', mk_paths (Mrec ind) irecargs)
 
-let check_positivity env_ar params inds =
+let check_positivity kn env_ar params inds =
   let ntypes = Array.length inds in
-  let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in
+  let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
   let lra_ind = List.rev (Array.to_list rc) in
   let lparams = rel_context_length params in
   let nmr = rel_context_nhyps params in
@@ -546,7 +542,7 @@ let check_positivity env_ar params inds =
       list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
     let nargs = rel_context_nhyps sign - nmr in
-    check_positivity_one ienv params i nargs lcnames lc
+    check_positivity_one ienv params (kn,i) nargs lcnames lc
   in
   let irecargs_nmr = Array.mapi check_one inds in
   let irecargs = Array.map snd irecargs_nmr
@@ -558,16 +554,6 @@ let check_positivity env_ar params 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
-*)
-
 (* Allowed eliminations *)
 
 let all_sorts = [InProp;InSet;InType]
@@ -614,7 +600,6 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
     (* Type of constructors in normal form *)
     let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
     let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
-    let nf_lc = if nf_lc = lc then lc else nf_lc in
     let consnrealargs =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
@@ -677,11 +662,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 (************************************************************************)
 (************************************************************************)
 
-let check_inductive env mie =
+let check_inductive env kn mie =
   (* First type-check the inductive definition *)
   let (env_ar, params, inds, cst) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
-  let (nmr,recargs) = check_positivity env_ar params inds in
+  let (nmr,recargs) = check_positivity kn env_ar params inds in
   (* Build the inductive packets *)
     build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
       inds nmr recargs cst
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 71d01568..b37aefe4 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
@@ -16,13 +13,13 @@ open Declarations
 open Environ
 open Entries
 open Typeops
-(*i*)
 
+(** Inductive type checking and errors *)
 
-(*s The different kinds of errors that may result of a malformed inductive
+(** The different kinds of errors that may result of a malformed inductive
   definition. *)
 
-(* Errors related to inductive constructions *)
+(** Errors related to inductive constructions *)
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
@@ -37,7 +34,7 @@ type inductive_error =
 
 exception InductiveError of inductive_error
 
-(*s The following function does checks on inductive declarations. *)
+(** The following function does checks on inductive declarations. *)
 
 val check_inductive :
-  env -> mutual_inductive_entry -> mutual_inductive_body
+  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 62a48f07..21f86233 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -80,8 +78,6 @@ let instantiate_params full t args sign =
   if rem_args <> [] then fail();
   substl subs ty
 
-let instantiate_partial_params = instantiate_params false
-
 let full_inductive_instantiate mib params sign =
   let dummy = prop_sort in
   let t = mkArity (sign,dummy) in
@@ -97,10 +93,6 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
 
 (* Functions to build standard types related to inductive *)
 
-
-let number_of_inductives mib = Array.length mib.mind_packets
-let number_of_constructors mip = Array.length mip.mind_consnames
-
 (*
 Computing the actual sort of an applied or partially applied inductive type:
 
@@ -241,12 +233,6 @@ let type_of_constructors ind (mib,mip) =
 
 (************************************************************************)
 
-let error_elim_expln kp ki =
-  match kp,ki with
-  | (InType | InSet), InProp -> NonInformativeToInformative
-  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
-  | _ -> WrongArity
-
 (* Type of case predicates *)
 
 let local_rels ctxt =
@@ -298,7 +284,7 @@ exception LocalArity of (sorts_family * sorts_family * arity_error) option
 let check_allowed_sort ksort specif =
   if not (List.exists ((=) ksort) (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
-    raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
+    raise (LocalArity (Some(ksort,s,error_elim_explain ksort s)))
 
 let is_correct_arity env c pj ind specif params =
   let arsign,_ = get_instantiated_arity specif params in
@@ -309,7 +295,7 @@ let is_correct_arity env c pj ind specif params =
           let univ =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ)
+          srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ)
       | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
           let ksort = match kind_of_term (whd_betadeltaiota env a2) with
             | Sort s -> family_of_sort s
@@ -319,13 +305,13 @@ let is_correct_arity env c pj ind specif params =
             try conv env a1 dep_ind
             with NotConvertible -> raise (LocalArity None) in
 	  check_allowed_sort ksort specif;
-	  Constraint.union u univ
+	  union_constraints u univ
       | _, (_,Some _,_ as d)::ar' ->
 	  srec (push_rel d env) (lift 1 pt') ar' u
       | _ ->
 	  raise (LocalArity None)
   in
-  try srec env pj.uj_type (List.rev arsign) Constraint.empty
+  try srec env pj.uj_type (List.rev arsign) empty_constraint
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c pj kinds
 
@@ -374,7 +360,7 @@ let check_case_info env indsp ci =
   if
     not (eq_ind indsp ci.ci_ind) or
     (mib.mind_nparams <> ci.ci_npar) or
-    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
+    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -431,10 +417,10 @@ let spec_of_tree t = lazy
    else Subterm(Strict,Lazy.force t))
 
 let subterm_spec_glb =
-  let glb2 s1 s2 =
-    match s1,s2 with
-        _, Dead_code -> s1
-      | Dead_code, _ -> s2
+  let glb2 s1 s2 = 
+    match s1, s2 with
+        s1, Dead_code -> s1
+      | Dead_code, s2 -> s2
       | Not_subterm, _ -> Not_subterm
       | _, Not_subterm -> Not_subterm
       | Subterm (a1,t1), Subterm (a2,t2) ->
@@ -447,27 +433,20 @@ 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 Lazy.t list;
   }
 
-let make_renv env minds recarg (kn,tyi) =
+let make_renv env 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 = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
 
 let push_var renv (x,ty,spec) =
-  { renv with
-    env = push_rel (x,None,ty) renv.env;
+  { env = push_rel (x,None,ty) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
 
@@ -475,76 +454,66 @@ 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,Lazy.lazy_from_val Not_subterm)
+  push_var renv (x,ty,lazy Not_subterm)
 
 (* Fetch recursive information about a variable p *)
 let subterm_var p renv =
   try Lazy.force (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;
+  { env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
-    genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+    genv = iterate (fun ge -> lazy 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;
+  { env = push_rec_types recdef renv.env;
     rel_min = renv.rel_min+n;
-    genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+    genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
 
+(* Definition and manipulation of the stack *)
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
 
-(******************************)
-(* Computing the recursive subterms of a term (propagation of size
-   information through Cases). *)
+let push_stack_closures renv l stack = 
+  List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack
 
-(*
-   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 push_stack_args l stack = 
+  List.fold_right (fun h b -> (SArg h)::b) l stack
+
+(******************************)
+(* {6 Computing the recursive subterms of a term (propagation of size
+   information through Cases).} *)
 
 let lookup_subterms env ind =
   let (_,mip) = lookup_mind_specif env ind in
   mip.mind_recargs
 
-(*********************************)
 
-let match_trees t1 t2 =
-  let v1 = dest_subterms t1 in
-  let v2 = dest_subterms t2 in
-  array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+let match_inductive ind ra =
+  match ra with
+    | (Mrec i | Imbr i) -> eq_ind ind i
+    | Norec -> false
 
-(* In {match c as z in ind y_s return P with |C_i x_s => t end}
-   [branches_specif renv c_spec ind] returns an array of x_s specs given
-   c_spec the spec of c. *)
-let branches_specif renv c_spec ind =
-  let (_,mip) = lookup_mind_specif renv.env ind in
+(* In {match c as z in ci y_s return P with |C_i x_s => t end}
+   [branches_specif renv c_spec ci] returns an array of x_s specs knowing
+   c_spec. *)
+let branches_specif renv c_spec ci =
   let car = 
     (* We fetch the regular tree associated to the inductive of the match.
        This is just to get the number of constructors (and constructor
        arities) that fit the match branches without forcing c_spec.
        Note that c_spec might be more precise than [v] below, because of
        nested inductive types. *)
+    let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in
     let v = dest_subterms mip.mind_recargs in
       Array.map List.length v in
     Array.mapi
       (fun i nca -> (* i+1-th cstructor has arity nca *)
 	 let lvra = lazy 
 	   (match Lazy.force c_spec with
-		Subterm (_,t) when match_trees mip.mind_recargs t ->
+		Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
 		  let vra = Array.of_list (dest_subterms t).(i) in
 		  assert (nca = Array.length vra);
 		  Array.map
@@ -555,106 +524,92 @@ let branches_specif renv c_spec ind =
 	 list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
       car 
 
-
-(* 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 to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr =
-  let vlrec = branches_specif renv c_spec ind in
-  let rec push_branch_args renv lrec c =
-    match lrec with
-        ra::lr ->
-          let c' = whd_betadeltaiota renv.env c in
-          (match kind_of_term c' with
-              Lambda(x,a,b) ->
-                let renv' = push_var renv (x,a,ra) in
-                push_branch_args renv' lr b
-            | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
-                (renv,c'))
-      | [] -> (renv, c) in
-  assert (Array.length vlrec = Array.length lbr);
-  array_map2 (push_branch_args renv) vlrec lbr
-
 (* [subterm_specif renv t] computes the recursive structure of [t] and
    compare its size with the size of the initial recursive argument of
    the fixpoint we are checking. [renv] collects such information
    about variables.
 *)
 
-let rec subterm_specif renv t =
+let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
   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) ->
-        let lbr_spec = case_subterm_specif renv ci c lbr in
-        let stl  =
-          Array.map (fun (renv',br') -> subterm_specif renv' br')
-            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 (ctxt,clfix) = dest_prod renv.env typarray.(i) in
-        let oind =
-          let env' = push_rel_context ctxt renv.env in
-          try Some(fst(find_inductive env' clfix))
-          with Not_found -> None in
-        (match oind with
-            None -> Not_subterm (* happens if fix is polymorphic *)
-          | Some ind ->
-              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' =
-                (* Why Strict here ? To be general, it could also be
-                   Large... *)
-                assign_var_spec renv'
-		  (nbfix-i, Lazy.lazy_from_val(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 theDecrArg  = List.nth l decrArg in
-	          let arg_spec    = lazy_subterm_specif renv theDecrArg in
-                  assign_var_spec renv'' (1, arg_spec) in
-	      subterm_specif renv'' strippedBody)
-
-    | Lambda (x,a,b) ->
-        assert (l=[]);
-        subterm_specif (push_var_renv renv (x,a)) b
-
-    (* Metas and evars are considered OK *)
-    | (Meta _|Evar _) -> Dead_code
-
-    (* Other terms are not subterms *)
-    | _ -> Not_subterm
-
-and lazy_subterm_specif renv t =
-  lazy (subterm_specif renv t)
-
-and case_subterm_specif renv ci c lbr =
-  if Array.length lbr = 0 then [||]
-  else
-    let c_spec = lazy_subterm_specif renv c in
-    case_branches_specif renv c_spec ci.ci_ind lbr
- 
+    match kind_of_term f with
+      | Rel k -> subterm_var k renv
+
+      | Case (ci,_,c,lbr) ->
+	  let stack' = push_stack_closures renv l stack in
+          let cases_spec = branches_specif renv 
+	    (lazy_subterm_specif renv [] c) ci in
+          let stl  =
+            Array.mapi (fun i br' ->
+			  let stack_br = push_stack_args (cases_spec.(i)) stack' in
+			    subterm_specif renv stack_br br')
+              lbr 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 (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+          let oind =
+            let env' = push_rel_context ctxt renv.env in
+              try Some(fst(find_inductive env' clfix))
+              with Not_found -> None in
+            (match oind with
+		 None -> Not_subterm (* happens if fix is polymorphic *)
+               | Some ind ->
+		   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' =
+                     (* Why Strict here ? To be general, it could also be
+			Large... *)
+                     assign_var_spec renv'
+		       (nbfix-i, lazy (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 stack' = push_stack_closures renv l stack in
+		   let renv'' = push_ctxt_renv renv' sign in
+		   let renv'' =
+                     if List.length stack' < nbOfAbst then renv''
+                     else
+		       let decrArg = List.nth stack' decrArg in
+                       let arg_spec = stack_element_specif decrArg in
+			 assign_var_spec renv'' (1, arg_spec) in
+		     subterm_specif renv'' [] strippedBody)
+
+      | Lambda (x,a,b) ->
+          assert (l=[]);
+	  let spec,stack' = extract_stack renv a stack in
+	    subterm_specif (push_var renv (x,a,spec)) stack' b
+
+      (* Metas and evars are considered OK *)
+      | (Meta _|Evar _) -> Dead_code
+
+      (* Other terms are not subterms *)
+      | _ -> Not_subterm
+
+and lazy_subterm_specif renv stack t =
+  lazy (subterm_specif renv stack t)
+
+and stack_element_specif = function
+  |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h
+  |SArg x -> x
+
+and extract_stack renv a = function
+  | [] -> Lazy.lazy_from_val Not_subterm , []
+  | h::t -> stack_element_specif h, t
+
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c =
-  match subterm_specif renv c with
+let check_is_subterm x =
+  match Lazy.force x with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
 
@@ -662,7 +617,7 @@ let check_is_subterm renv c =
 
 exception FixGuardError of env * guard_error
 
-let error_illegal_rec_call renv fx arg =
+let error_illegal_rec_call renv fx (arg_renv,arg) =
   let (_,le_vars,lt_vars) =
     List.fold_left
       (fun (i,le,lt) sbt ->
@@ -672,7 +627,8 @@ let error_illegal_rec_call renv fx arg =
           | _ -> (i+1, le ,lt))
       (1,[],[]) renv.genv in
   raise (FixGuardError (renv.env,
-                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+                        RecursionOnIllegalTerm(fx,(arg_renv.env, arg),
+					       le_vars,lt_vars)))
 
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
@@ -683,8 +639,11 @@ let error_partial_apply renv fx =
 let check_one_fix renv recpos def =
   let nfi = Array.length recpos in
 
-  (* Checks if [t] only make valid recursive calls *)
-  let rec check_rec_call renv t =
+  (* Checks if [t] only make valid recursive calls 
+     [stack] is the list of constructor's argument specification and 
+     arguments than will be applied after reduction.
+     example u in t where we have (match .. with |.. => t end) u *)
+  let rec check_rec_call renv stack t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
@@ -694,35 +653,43 @@ let check_one_fix renv recpos def =
             (* Test if [p] is a fixpoint (recursive call) *)
 	    if renv.rel_min <= p & p < renv.rel_min+nfi then
               begin
-                List.iter (check_rec_call renv) l;
+                List.iter (check_rec_call renv []) l;
                 (* 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
+		let stack' = push_stack_closures renv l stack in
+                if List.length stack' <= np then error_partial_apply renv glob
                 else
                   (* Check the decreasing arg is smaller *)
-                  let z = List.nth l np in
-	          if not (check_is_subterm renv z) then
-                    error_illegal_rec_call renv glob z
+                  let z = List.nth stack' np in
+	          if not (check_is_subterm (stack_element_specif z)) then
+                    begin match z with
+		      |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') 
+		      |SArg _ -> error_partial_apply renv glob
+		    end
               end
             else
               begin
                 match pi2 (lookup_rel p renv.env) with
                 | None ->
-                    List.iter (check_rec_call renv) l
+                    List.iter (check_rec_call renv []) l
                 | Some c ->
-                    try List.iter (check_rec_call renv) l
+                    try List.iter (check_rec_call renv []) l
                     with FixGuardError _ ->
-                      check_rec_call renv (applist(lift p c,l))
+                      check_rec_call renv stack (applist(lift p c,l))
               end
-
+		
         | Case (ci,p,c_0,lrest) ->
-            List.iter (check_rec_call renv) (c_0::p::l);
+            List.iter (check_rec_call renv []) (c_0::p::l);
             (* compute the recarg information for the arguments of
                each branch *)
-            let lbr = case_subterm_specif renv ci c_0 lrest in
-            Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+            let case_spec = branches_specif renv 
+	      (lazy_subterm_specif renv [] c_0) ci in
+	    let stack' = push_stack_closures renv l stack in
+              Array.iteri (fun k br' -> 
+			     let stack_br = push_stack_args case_spec.(k) stack' in
+			     check_rec_call renv stack_br br') lrest
 
         (* Enables to traverse Fixpoint definitions in a more intelligent
            way, ie, the rule :
@@ -737,79 +704,79 @@ let check_one_fix renv recpos def =
            then f is guarded with respect to S in (g a1 ... am).
            Eduardo 7/9/98 *)
         | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
-            List.iter (check_rec_call renv) l;
-            Array.iter (check_rec_call renv) typarray;
+            List.iter (check_rec_call renv []) l;
+            Array.iter (check_rec_call renv []) typarray;
             let decrArg = recindxs.(i) in
             let renv' = push_fix_renv renv recdef in
-            if (List.length l < (decrArg+1)) then
-	      Array.iter (check_rec_call renv') bodies
-            else
+	    let stack' = push_stack_closures renv l stack in
               Array.iteri
                 (fun j body ->
-                  if i=j then
-                    let theDecrArg  = List.nth l decrArg in
-	            let arg_spec = lazy_subterm_specif renv theDecrArg in
-	            check_nested_fix_body renv' (decrArg+1) arg_spec body
-                  else check_rec_call renv' body)
+                   if i=j && (List.length stack' > decrArg) then
+		     let recArg = List.nth stack' decrArg in
+	             let arg_sp = stack_element_specif recArg in
+	             check_nested_fix_body renv' (decrArg+1) arg_sp body
+                   else check_rec_call renv' [] body)
                 bodies
 
         | Const kn ->
             if evaluable_constant kn renv.env then
-              try List.iter (check_rec_call renv) l
+              try List.iter (check_rec_call renv []) l
               with (FixGuardError _ ) ->
-	        check_rec_call renv(applist(constant_value renv.env kn, l))
-	    else List.iter (check_rec_call renv) l
-
-        (* The cases below simply check recursively the condition on the
-           subterms *)
-        | Cast (a,_, b) ->
-            List.iter (check_rec_call renv) (a::b::l)
+		let value = (applist(constant_value renv.env kn, l)) in
+	        check_rec_call renv stack value
+	    else List.iter (check_rec_call renv []) l
 
         | Lambda (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = []);
+	    check_rec_call renv [] a ;
+	    let spec, stack' = extract_stack renv a stack in
+	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = [] && stack = []);
+            check_rec_call renv [] a;
+            check_rec_call (push_var_renv renv (x,a)) [] b
 
         | CoFix (i,(_,typarray,bodies as recdef)) ->
-            List.iter (check_rec_call renv) l;
-	    Array.iter (check_rec_call renv) typarray;
+            List.iter (check_rec_call renv []) l;
+	    Array.iter (check_rec_call renv []) typarray;
 	    let renv' = push_fix_renv renv recdef in
-	    Array.iter (check_rec_call renv') bodies
+	    Array.iter (check_rec_call renv' []) bodies
 
-        | (Ind _ | Construct _ | Sort _) ->
-            List.iter (check_rec_call renv) l
+        | (Ind _ | Construct _) ->
+            List.iter (check_rec_call renv []) l
 
         | Var id ->
             begin
               match pi2 (lookup_named id renv.env) with
               | None ->
-                  List.iter (check_rec_call renv) l
+                  List.iter (check_rec_call renv []) l
               | Some c ->
-                  try List.iter (check_rec_call renv) l
-                  with (FixGuardError _) -> check_rec_call renv (applist(c,l))
+                  try List.iter (check_rec_call renv []) l
+                  with (FixGuardError _) -> 
+		    check_rec_call renv stack (applist(c,l))
             end
 
+	| Sort _ -> assert (l = [])
+
         (* l is not checked because it is considered as the meta's context *)
         | (Evar _ | Meta _) -> ()
 
-        | (App _ | LetIn _) -> assert false (* beta zeta reduction *)
+        | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
 
   and check_nested_fix_body renv decr recArgsDecrArg body =
     if decr = 0 then
-      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
     else
       match kind_of_term body with
 	| Lambda (x,a,b) ->
-	    check_rec_call renv a;
+	    check_rec_call renv [] a;
             let renv' = push_var_renv renv (x,a) in
-	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+	      check_nested_fix_body renv' (decr-1) recArgsDecrArg b
 	| _ -> anomaly "Not enough abstractions in fix body"
-
+	    
   in
-  check_rec_call renv def
+  check_rec_call renv [] def
 
 let judgment_of_fixpoint (_, types, bodies) =
   array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
@@ -856,7 +823,7 @@ 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
+    let renv = make_renv fenv nvect.(i) minds.(i) in
     try check_one_fix renv nvect body
     with FixGuardError (fixenv,err) ->
       error_ill_formed_rec_body fixenv err names i
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 0dac719c..a124647c 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Declarations
 open Environ
-(*i*)
 
-(*s Extracting an inductive type from a construction *)
+(** {6 Extracting an inductive type from a construction } *)
 
-(* [find_m*type env sigma c] coerce [c] to an recursive type (I args).
+(** [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.
@@ -30,32 +26,33 @@ val find_coinductive : env -> types -> inductive * constr list
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
-(*s Fetching information in the environment about an inductive type.
+(** {6 ... } *)
+(** 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 -> mind_specif
 
-(*s Functions to build standard types related to inductive *)
+(** {6 Functions to build standard types related to inductive } *)
 val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
 
 val type_of_inductive : env -> mind_specif -> types
 
 val elim_sorts : mind_specif -> sorts_family list
 
-(* Return type as quoted by the user *)
+(** Return type as quoted by the user *)
 val type_of_constructor : constructor -> mind_specif -> types
 
-(* Return constructor types in normal form *)
+(** Return constructor types in normal form *)
 val arities_of_constructors : inductive -> mind_specif -> types array
 
-(* Return constructor types in user form *)
+(** Return constructor types in user form *)
 val type_of_constructors : inductive -> mind_specif -> types array
 
-(* Transforms inductive specification into types (in nf) *)
+(** Transforms inductive specification into types (in nf) *)
 val arities_of_specif : mutual_inductive -> mind_specif -> types array
 
 val inductive_params : mind_specif -> int
 
-(* [type_case_branches env (I,args) (p:A) c] computes useful types
+(** [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
@@ -70,20 +67,20 @@ val build_branches_type :
   inductive -> mutual_inductive_body * one_inductive_body ->
     constr list -> constr -> types array
 
-(* Return the arity of an inductive type *)
+(** Return the arity of an inductive type *)
 val mind_arity : one_inductive_body -> rel_context * sorts_family
 
 val inductive_sort_family : one_inductive_body -> sorts_family
 
-(* Check a [case_info] actually correspond to a Case expression on the
+(** Check a [case_info] actually correspond to a Case expression on the
    given inductive type. *)
 val check_case_info : env -> inductive -> case_info -> unit
 
-(*s Guard conditions for fix and cofix-points. *)
+(** {6 Guard conditions for fix and cofix-points. } *)
 val check_fix : env -> fixpoint -> unit
 val check_cofix : env -> cofixpoint -> unit
 
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
 
 (** The "polyprop" optional argument below allows to control
     the "Prop-polymorphism". By default, it is allowed.
@@ -102,8 +99,7 @@ val max_inductive_sort : sorts array -> universe
 val instantiate_universes : env -> rel_context ->
     polymorphic_arity -> types array -> rel_context * sorts
 
-(***************************************************************)
-(* Debug *)
+(** {6 Debug} *)
 
 type size = Large | Strict
 type subterm_spec =
@@ -112,16 +108,13 @@ type subterm_spec =
   | Not_subterm
 type guard_env =
   { env     : env;
-    (* dB of last fixpoint *)
+    (** 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 *)
+    (** dB of variables denoting subterms *)
     genv    : subterm_spec Lazy.t list;
   }
 
-val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
-  constr array -> (guard_env * constr) array
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
+
+val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
+
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index ab8b60be..314cc0ee 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -1,305 +1,249 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: mod_subst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Claudio Sacerdoti from contents of term.ml, names.ml and
+   new support for constant inlining in functor application, Nov 2004 *)
+(* Optimizations and bug fixes by Élie Soubiran, from Feb 2008 *)
+
+(* This file provides types and functions for managing name
+   substitution in module constructions *)
 
 open Pp
 open Util
 open Names
 open Term
 
+(* For Inline, the int is an inlining level, and the constr (if present)
+   is the term into which we should inline *)
 
 type delta_hint =
-    Inline of constr option
+  | Inline of int * constr option
   | Equiv of kernel_name
-  | Prefix_equiv of module_path
 
-type delta_key = 
-    KN of kernel_name
-  | MP of module_path
+(* NB: earlier constructor Prefix_equiv of module_path
+   is now stored in a separate table, see Deltamap.t below *)
+
+module Deltamap = struct
+  type t = module_path MPmap.t * delta_hint KNmap.t
+  let empty = MPmap.empty, KNmap.empty
+  let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
+  let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_kn kn map = KNmap.find kn (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_kn kn map = KNmap.mem kn (snd map)
+  let fold_kn f map i = KNmap.fold f (snd map) i
+  let fold fmp fkn (mm,km) i =
+    MPmap.fold fmp mm (KNmap.fold fkn km i)
+  let join map1 map2 = fold add_mp add_kn map1 map2
+end
+
+type delta_resolver = Deltamap.t
 
-module Deltamap =  Map.Make(struct 
-			      type t = delta_key
-			      let compare = Pervasives.compare
-			    end)
+let empty_delta_resolver = Deltamap.empty
 
-type delta_resolver = delta_hint Deltamap.t
+module MBImap = Map.Make
+  (struct
+    type t = mod_bound_id
+    let compare = Pervasives.compare
+   end)
+
+module Umap = struct
+  type 'a t = 'a MPmap.t * 'a MBImap.t
+  let empty = MPmap.empty, MBImap.empty
+  let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2
+  let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2)
+  let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_mbi mbi map = MBImap.find mbi (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_mbi mbi map = MBImap.mem mbi (snd map)
+  let iter_mbi f map = MBImap.iter f (snd map)
+  let fold fmp fmbi (m1,m2) i =
+    MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
+  let join map1 map2 = fold add_mp add_mbi map1 map2
+end
 
-let empty_delta_resolver = Deltamap.empty
+type substitution = (module_path * delta_resolver) Umap.t
 
-type substitution_domain = 
-  | MBI of mod_bound_id
-  | MPI of module_path
+let empty_subst = Umap.empty
 
-let string_of_subst_domain = function
- | MBI mbid -> debug_string_of_mbid mbid
- | MPI mp -> string_of_mp mp
+let is_empty_subst = Umap.is_empty
 
-module Umap = Map.Make(struct
-			 type t = substitution_domain
-			 let compare = Pervasives.compare
-		       end)
+(* <debug> *)
 
-type substitution = (module_path * delta_resolver) Umap.t
-    
-let empty_subst = Umap.empty
+let string_of_hint = function
+  | Inline (_,Some _) -> "inline(Some _)"
+  | Inline _ -> "inline()"
+  | Equiv kn -> string_of_kn kn
+
+let debug_string_of_delta resolve =
+  let kn_to_string kn hint s =
+    s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint)
+  in
+  let mp_to_string mp mp' s =
+    s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp')
+  in
+  Deltamap.fold mp_to_string kn_to_string resolve ""
+
+let list_contents sub =
+  let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in
+  let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in
+  let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in
+  Umap.fold mp_one_pair mbi_one_pair sub []
+
+let debug_string_of_subst sub =
+  let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]")
+    (list_contents sub)
+  in
+  "{" ^ String.concat "; " l ^ "}"
+
+let debug_pr_delta resolve =
+  str (debug_string_of_delta resolve)
+
+let debug_pr_subst sub =
+  let l = list_contents sub in
+  let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++
+			      spc () ++ str "[" ++ str s3 ++ str "]")
+  in
+  str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}"
 
+(* </debug> *)
 
-let string_of_subst_domain = function
-  | MBI mbid -> debug_string_of_mbid mbid
-  | MPI mp -> string_of_mp mp
-      
-let add_mbid mbid mp resolve =
-  Umap.add (MBI mbid) (mp,resolve)
-let add_mp mp1 mp2 resolve =
-  Umap.add (MPI mp1) (mp2,resolve)
+(** Extending a [delta_resolver] *)
 
+let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc))
+
+let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn')
+
+let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2
+
+(** Extending a [substitution *)
+
+let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s
+let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s
 
 let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst
 let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst
 
-let add_inline_delta_resolver con =
-  Deltamap.add (KN(user_con con)) (Inline None)
-    
-let add_inline_constr_delta_resolver con cstr =
-  Deltamap.add (KN(user_con con)) (Inline (Some cstr))
-
-let add_constant_delta_resolver con =
-  Deltamap.add (KN(user_con con)) (Equiv (canonical_con con))
-
-let add_mind_delta_resolver mind =
-  Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind))
-
-let add_mp_delta_resolver mp1 mp2 = 
-  Deltamap.add (MP mp1) (Prefix_equiv mp2)
-
-let mp_in_delta mp = 
-  Deltamap.mem (MP mp) 
-
-let con_in_delta con resolver = 
-try 
-  match Deltamap.find (KN(user_con con)) resolver with
-  | Inline _  | Prefix_equiv _ -> false
-  | Equiv _ -> true
-with
- Not_found -> false
-
-let mind_in_delta mind resolver = 
-try 
-  match Deltamap.find (KN(user_mind mind)) resolver with
-  | Inline _  | Prefix_equiv _ -> false
-  | Equiv _ -> true
-with
- Not_found -> false
-
-let delta_of_mp resolve mp =
-  try 
-    match Deltamap.find (MP mp) resolve with
-      | Prefix_equiv mp1 -> mp1
-      | _ -> anomaly "mod_subst: bad association in delta_resolver"
-  with
-      Not_found -> mp
-	
-let delta_of_kn resolve kn =
-  try 
-    match Deltamap.find (KN kn) resolve with
-      | Equiv kn1 -> kn1
-      | Inline _ -> kn
-      | _ -> anomaly 
-	  "mod_subst: bad association in delta_resolver"
-  with
-      Not_found -> kn
+let mp_in_delta mp = Deltamap.mem_mp mp
 
-let remove_mp_delta_resolver resolver mp =
-    Deltamap.remove (MP mp) resolver
+let kn_in_delta kn resolver =
+  try
+    match Deltamap.find_kn kn resolver with
+      | Equiv _ -> true
+      | Inline _ -> false
+  with Not_found -> false
 
-exception Inline_kn
+let con_in_delta con resolver = kn_in_delta (user_con con) resolver
+let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver
 
-let rec find_prefix resolve mp = 
+let mp_of_delta resolve mp =
+ try Deltamap.find_mp mp resolve with Not_found -> mp
+
+let rec find_prefix resolve mp =
   let rec sub_mp = function
-    | MPdot(mp,l) as mp_sup -> 
-	(try 
-	   match Deltamap.find (MP mp_sup) resolve with
-	     | Prefix_equiv mp1 -> mp1
-	     | _ -> anomaly 
-		 "mod_subst: bad association in delta_resolver"
-	 with
-	     Not_found -> MPdot(sub_mp mp,l))
-    | p -> 
-	match Deltamap.find (MP p) resolve with
-	  | Prefix_equiv mp1 -> mp1
-	  | _ -> anomaly 
-		 "mod_subst: bad association in delta_resolver"	
+    | MPdot(mp,l) as mp_sup ->
+	(try Deltamap.find_mp mp_sup resolve
+	 with Not_found -> MPdot(sub_mp mp,l))
+    | p -> Deltamap.find_mp p resolve
   in
-    try 
-      sub_mp mp
-    with
-	Not_found -> mp
+  try sub_mp mp with Not_found -> mp
 
-exception Change_equiv_to_inline of constr
+exception Change_equiv_to_inline of (int * constr)
 
 let solve_delta_kn resolve kn =
-  try 
-      match Deltamap.find (KN kn) resolve with
-	| Equiv kn1 -> kn1
-	| Inline (Some c) -> 
-	    raise (Change_equiv_to_inline c)
-	| Inline None -> raise Inline_kn
-	| _ -> anomaly 
-	    "mod_subst: bad association in delta_resolver"
-  with
-      Not_found | Inline_kn -> 
-	let mp,dir,l = repr_kn kn in
-	let new_mp = find_prefix resolve mp in
-	  if mp == new_mp then 
-	    kn
-	  else
-	    make_kn new_mp dir l
-	      
+  try
+    match Deltamap.find_kn kn resolve with
+      | Equiv kn1 -> kn1
+      | Inline (lev, Some c) ->	raise (Change_equiv_to_inline (lev,c))
+      | Inline (_, None) -> raise Not_found
+  with Not_found ->
+    let mp,dir,l = repr_kn kn in
+    let new_mp = find_prefix resolve mp in
+    if mp == new_mp then
+      kn
+    else
+      make_kn new_mp dir l
+
+let kn_of_delta resolve kn =
+  try solve_delta_kn resolve kn
+  with _ -> kn
+
+let constant_of_delta_kn resolve kn =
+  constant_of_kn_equiv kn (kn_of_delta resolve kn)
+
+let gen_of_delta resolve x kn fix_can =
+  try
+    let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then x else fix_can new_kn
+  with _ -> x
 
 let constant_of_delta resolve con =
   let kn = user_con con in
-    try 
-      let new_kn = solve_delta_kn resolve kn in
-	if kn == new_kn then
-	  con
-	else
-	  constant_of_kn_equiv kn new_kn
-    with 
-	_ -> con 
-	
+  gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+
 let constant_of_delta2 resolve con =
-  let kn = canonical_con con in
-  let kn1 = user_con con in
-    try 
-      let new_kn = solve_delta_kn resolve kn in
-	if kn == new_kn then
-	  con
-	else
-	  constant_of_kn_equiv kn1 new_kn
-    with 
-	_ -> con
+  let kn, kn' = canonical_con con, user_con con in
+  gen_of_delta resolve con kn (constant_of_kn_equiv kn')
+
+let mind_of_delta_kn resolve kn =
+  mind_of_kn_equiv kn (kn_of_delta resolve kn)
 
 let mind_of_delta resolve mind =
   let kn = user_mind mind in
-    try
-      let new_kn = solve_delta_kn resolve kn in
-	if kn == new_kn then
-	  mind
-	else
-	  mind_of_kn_equiv kn new_kn
-    with 
-	_ -> mind 
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
 
 let mind_of_delta2 resolve mind =
-  let kn = canonical_mind mind in
-  let kn1 = user_mind mind in
-    try
-      let new_kn = solve_delta_kn resolve kn in
-	if kn == new_kn then
-	  mind
-	else
-	  mind_of_kn_equiv kn1 new_kn
-    with 
-	_ -> mind
-	  
-
-let inline_of_delta resolver = 
-  let extract key hint l =
-    match key,hint with 
-      |KN kn, Inline _ -> kn::l
-      | _,_ -> l
-  in
-    Deltamap.fold extract resolver []
+  let kn, kn' = canonical_mind mind, user_mind mind in
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
+
+let inline_of_delta inline resolver =
+  match inline with
+    | None -> []
+    | Some inl_lev ->
+      let extract kn hint l =
+	match hint with
+	  | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l
+	  | _ -> l
+      in
+      Deltamap.fold_kn extract resolver []
+
+let find_inline_of_delta kn resolve =
+  match Deltamap.find_kn kn resolve with
+    | Inline (_,o) -> o
+    | _ -> raise Not_found
 
-exception Not_inline
-  
 let constant_of_delta_with_inline resolve con =
   let kn1,kn2 = canonical_con con,user_con con in
-    try
-      match Deltamap.find (KN kn2) resolve with 
-	| Inline None -> None
-	| Inline (Some const) -> Some const
-	| _ -> raise Not_inline
-    with
-	Not_found | Not_inline -> 
-	  try match Deltamap.find (KN kn1) resolve with 
-	    | Inline None -> None
-	    | Inline (Some const) -> Some const
-	    | _ -> raise Not_inline
-	  with
-	      Not_found | Not_inline -> None
-
-let string_of_key = function
-      | KN kn -> string_of_kn kn
-      | MP mp -> string_of_mp mp
+  try find_inline_of_delta kn2 resolve
+  with Not_found ->
+    try find_inline_of_delta kn1 resolve
+    with Not_found -> None
 
-let string_of_hint = function
-      | Inline _ -> "inline"
-      | Equiv kn -> string_of_kn kn
-      | Prefix_equiv mp -> string_of_mp mp
-
-let debug_string_of_delta resolve =
-  let to_string key hint s = 
-    s^", "^(string_of_key key)^"=>"^(string_of_hint hint)
-  in 
-    Deltamap.fold to_string resolve ""  
-      
-let list_contents sub = 
-  let one_pair uid (mp,reso) l =
-    (string_of_subst_domain uid, string_of_mp mp,debug_string_of_delta reso)::l
-  in
-    Umap.fold one_pair sub []
-      
-let debug_string_of_subst sub =
-  let l = List.map (fun (s1,s2,s3) -> s1^"|->"^s2^"["^s3^"]")
-    (list_contents sub) in
-    "{" ^ String.concat "; " l ^ "}"
-      
-let debug_pr_delta resolve = 
-  str (debug_string_of_delta resolve)
-
-let debug_pr_subst sub =
-  let l = list_contents sub in
-  let f (s1,s2,s3) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++
-			      spc () ++ str "[" ++ str s3 ++ str "]") 
-  in
-    str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}"
-      
-      
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
-    | MPfile sid -> 
-        let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
-         mp',resolve
+    | MPfile sid -> Umap.find_mp mp sub
     | MPbound bid ->
 	begin
-	  try
-            let mp',resolve = Umap.find (MBI bid) sub in
-              mp',resolve
-	  with Not_found ->
-	    let mp',resolve = Umap.find (MPI mp) sub in
-              mp',resolve
+	  try Umap.find_mbi bid sub
+	  with Not_found -> Umap.find_mp mp sub
 	end
     | MPdot (mp1,l) as mp2 ->
 	begin
-	  try
-	    let mp',resolve = Umap.find (MPI mp2) sub in
-              mp',resolve
+	  try Umap.find_mp mp2 sub
 	  with Not_found ->
 	    let mp1',resolve = aux mp1 in
-	      MPdot (mp1',l),resolve
+	    MPdot (mp1',l),resolve
 	end
  in
-  try
-    Some (aux mp)
-  with Not_found -> None
+ try Some (aux mp) with Not_found -> None
 
 let subst_mp sub mp =
  match subst_mp0 sub mp with
@@ -327,107 +271,47 @@ type sideconstantsubst =
   | User
   | Canonical
 
-let subst_ind sub mind =
-  let kn1,kn2 = user_mind mind,canonical_mind mind in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-    try 
-      let side,mind',resolve =   
-        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
-	    None,None ->raise No_subst
-	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
-	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
-	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
-	      (make_mind_equiv mp1' mp2' dir l), resolve2 
-      in
-	match side with
-	  |User ->
-	     let mind = mind_of_delta resolve mind' in
-	       mind
-	  |Canonical ->
-	     let mind = mind_of_delta2 resolve mind' in
-	       mind
-    with 
-	No_subst -> mind
-
-let subst_mind0 sub mind =
-  let kn1,kn2 = user_mind mind,canonical_mind mind in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-    try 
-      let side,mind',resolve =   
-        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
-	    None,None ->raise No_subst
-	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
-	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
-	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
-	      (make_mind_equiv mp1' mp2' dir l), resolve2
-      in
-	match side with
-	  |User ->
-	     let mind = mind_of_delta resolve mind' in
-	       Some mind
-	  |Canonical ->
-	     let mind = mind_of_delta2 resolve mind' in
-	       Some mind
-    with 
-	No_subst -> Some mind
+let gen_subst_mp f sub mp1 mp2 =
+  match subst_mp0 sub mp1, subst_mp0 sub mp2 with
+    | None, None -> raise No_subst
+    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
+    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
+    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
 
-let subst_con sub con =
-  let kn1,kn2 = user_con con,canonical_con con in
+let subst_ind sub mind =
+  let kn1,kn2 = user_mind mind, canonical_mind mind in
   let mp1,dir,l = repr_kn kn1 in
   let mp2,_,_ = repr_kn kn2 in
-    try 
-      let side,con',resolve =   
-        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
-	    None,None ->raise No_subst
-	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
-	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
-	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
-	      (make_con_equiv mp1' mp2' dir l), resolve2 
-      in
-	match constant_of_delta_with_inline resolve con' with
-            None -> begin
-	      match side with
-	      |User ->
-	      let con = constant_of_delta resolve con' in
-		con,mkConst con
-	      |Canonical ->
-		  let con = constant_of_delta2 resolve con' in
-		con,mkConst con
-	    end
-	  | Some t ->
-	    (* In case of inlining, discard the canonical part (cf #2608) *)
-	    constant_of_kn (user_con con'), t
-    with No_subst -> con , mkConst con 
- 
+  let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+  try
+    let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
+    match side with
+      | User -> mind_of_delta resolve mind'
+      | Canonical -> mind_of_delta2 resolve mind'
+  with No_subst -> mind
 
 let subst_con0 sub con =
   let kn1,kn2 = user_con con,canonical_con con in
   let mp1,dir,l = repr_kn kn1 in
   let mp2,_,_ = repr_kn kn2 in
-    try  
-      let side,con',resolve =   
-	match subst_mp0 sub mp1,subst_mp0 sub mp2 with
-	    None,None ->raise No_subst
-	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
-	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
-	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
-	      (make_con_equiv mp1' mp2' dir l), resolve2 
+  let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
+  let dup con = con, mkConst con in
+  let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
+  match constant_of_delta_with_inline resolve con' with
+    | Some t ->
+      (* In case of inlining, discard the canonical part (cf #2608) *)
+      constant_of_kn (user_con con'), t
+    | None ->
+      let con'' = match side with
+	| User -> constant_of_delta resolve con'
+	| Canonical -> constant_of_delta2 resolve con'
       in
-	match constant_of_delta_with_inline resolve con' with
-	    None ->begin
-	      match side with
-	      |User ->
-	      let con = constant_of_delta resolve con' in
-		Some (mkConst con)
-	      |Canonical ->
-		  let con = constant_of_delta2 resolve con' in
-		Some (mkConst con)
-	    end
-	  | t ->  t
-    with No_subst -> Some (mkConst con) 
-		
+      if con'' == con then raise No_subst else dup con''
+
+let subst_con sub con =
+  try subst_con0 sub con
+  with No_subst -> con, mkConst con
+
 (* Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
@@ -437,29 +321,22 @@ let subst_evaluable_reference subst = function
   | EvalVarRef id -> EvalVarRef id
   | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
 
-
-
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match kind_of_term c with
-      | Const kn ->
-	  (match f' kn with
-	       None -> c
-	     | Some const ->const)
+      | Const kn -> (try snd (f' kn) with No_subst -> c)
       | Ind (kn,i) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	      mkInd (kn',i))
+	  let kn' = f kn in
+	  if kn'==kn then c else mkInd (kn',i)
       | Construct ((kn,i),j) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	       mkConstruct ((kn',i),j))
+	  let kn' = f kn in
+	  if kn'==kn then c else mkConstruct ((kn',i),j)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
-              (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
+	    let kn' = f kn in
+	    if kn'==kn then ci.ci_ind else kn',i
+	  in
 	  let p' = func p in
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
@@ -510,8 +387,9 @@ let rec map_kn f f' c =
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-let subst_mps sub =
-  map_kn (subst_mind0 sub) (subst_con0 sub)
+let subst_mps sub c =
+  if is_empty_subst sub then c
+  else map_kn (subst_ind sub) (subst_con0 sub) c
 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
@@ -533,117 +411,76 @@ let rec mp_in_mp mp mp1 =
     | _ when mp1 = mp -> true
     | MPdot (mp2,l) -> mp_in_mp mp mp2
     | _ -> false
-	
-let mp_in_key mp key = 
-  match key with
-    | MP mp1 -> 
-	mp_in_mp mp mp1
-    | KN kn -> 
-	let mp1,dir,l = repr_kn kn in
-	  mp_in_mp mp mp1
-	    
+
 let subset_prefixed_by mp resolver =
-  let prefixmp key hint resolv =
-    match hint with 
-      | Inline _ -> resolv
-      | _ ->
-	  if mp_in_key mp key then
-	    Deltamap.add key hint resolv
-	  else 
-	    resolv
+  let mp_prefix mkey mequ rslv =
+    if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv
+  in
+  let kn_prefix kn hint rslv =
+    match hint with
+      | Inline _ -> rslv
+      | Equiv _ ->
+	if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv
   in
-    Deltamap.fold prefixmp resolver empty_delta_resolver
+  Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver
 
 let subst_dom_delta_resolver subst resolver =
-  let apply_subst key hint resolver =
-    match key with
-	(MP mp) ->
-	  Deltamap.add (MP (subst_mp subst mp)) hint resolver
-      | (KN kn) ->
-	  Deltamap.add (KN (subst_kn subst kn)) hint resolver
+  let mp_apply_subst mkey mequ rslv =
+    Deltamap.add_mp (subst_mp subst mkey) mequ rslv
+  in
+  let kn_apply_subst kkey hint rslv =
+    Deltamap.add_kn (subst_kn subst kkey) hint rslv
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
 
-let subst_mp_delta sub mp key=
+let subst_mp_delta sub mp mkey =
  match subst_mp0 sub mp with
     None -> empty_delta_resolver,mp
-  | Some (mp',resolve) -> 
+  | Some (mp',resolve) ->
       let mp1 = find_prefix resolve mp' in
       let resolve1 = subset_prefixed_by mp1 resolve in
-	match key with
-	    MP mpk ->
-	      (subst_dom_delta_resolver 
-		 (map_mp mp1 mpk empty_delta_resolver) resolve1),mp1
-	  | _ -> anomaly "Mod_subst: Bad association in resolver" 
-
-let subst_codom_delta_resolver subst resolver =
-  let apply_subst key hint resolver =
-    match hint with
-	Prefix_equiv mp ->
-	  let derived_resolve,mpnew = subst_mp_delta subst mp key in
-	    Deltamap.fold Deltamap.add derived_resolve
-	      (Deltamap.add key (Prefix_equiv mpnew) resolver)
-      | (Equiv kn) ->
-	  (try
-	     Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
-	   with
-	       Change_equiv_to_inline c ->
-		 Deltamap.add key (Inline (Some c)) resolver)
-      | Inline None ->
-	  Deltamap.add key hint resolver
-      | Inline (Some t) ->
-	  Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
+      (subst_dom_delta_resolver
+	 (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1
+
+let gen_subst_delta_resolver dom subst resolver =
+  let mp_apply_subst mkey mequ rslv =
+    let mkey' = if dom then subst_mp subst mkey else mkey in
+    let rslv',mequ' = subst_mp_delta subst mequ mkey in
+    Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv)
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
-
-let subst_dom_codom_delta_resolver subst resolver =
-  let apply_subst key hint resolver =
-    match key,hint with
-	(MP mp1),Prefix_equiv mp ->
-	  let key = MP (subst_mp subst mp1) in
-	  let derived_resolve,mpnew = subst_mp_delta subst mp key in
-	    Deltamap.fold Deltamap.add derived_resolve
-	      (Deltamap.add key (Prefix_equiv mpnew) resolver)
-      | (KN kn1),(Equiv kn) ->
-	  let key = KN (subst_kn subst kn1) in
-	    (try
-	       Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
-	     with
-		 Change_equiv_to_inline c ->
-		   Deltamap.add key (Inline (Some c)) resolver)
-      | (KN kn),Inline None ->
-	  let key = KN (subst_kn subst kn) in
-	    Deltamap.add key hint resolver
-      | (KN kn),Inline (Some t) ->
-	  let key = KN (subst_kn subst kn) in
-	  Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
-      | _,_ -> anomaly "Mod_subst: Bad association in resolver" 
+  let kn_apply_subst kkey hint rslv =
+    let kkey' = if dom then subst_kn subst kkey else kkey in
+    let hint' = match hint with
+      | Equiv kequ ->
+	  (try Equiv (subst_kn_delta subst kequ)
+	   with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c))
+      | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t))
+      | Inline (_,None) -> hint
+    in
+    Deltamap.add_kn kkey' hint' rslv
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
+
+let subst_codom_delta_resolver = gen_subst_delta_resolver false
+let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
 
 let update_delta_resolver resolver1 resolver2 =
- let apply_res key hint res = 
-      try
-	if Deltamap.mem key resolver2 then
-	  res else
-	match hint with
-	    Prefix_equiv mp ->
-	      let new_hint =
-		Prefix_equiv (find_prefix resolver2 mp)
-	      in Deltamap.add key new_hint res
-	  | Equiv kn ->
-	      (try 
-		 let new_hint =
-		   Equiv (solve_delta_kn resolver2 kn)
-		 in Deltamap.add key new_hint res
-	       with
-		   Change_equiv_to_inline c ->
-		     Deltamap.add key (Inline (Some c)) res)
-	  | _ -> Deltamap.add key hint res
-      with Not_found ->
-	Deltamap.add key hint res
-    in
-      Deltamap.fold apply_res resolver1 empty_delta_resolver
+  let mp_apply_rslv mkey mequ rslv =
+    if Deltamap.mem_mp mkey resolver2 then rslv
+    else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+  in
+  let kn_apply_rslv kkey hint rslv =
+    if Deltamap.mem_kn kkey resolver2 then rslv
+    else
+      let hint' = match hint with
+	| Equiv kequ ->
+	  (try Equiv (solve_delta_kn resolver2 kequ)
+	   with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
+	| _ -> hint
+      in
+      Deltamap.add_kn kkey hint' rslv
+  in
+  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver
 
 let add_delta_resolver resolver1 resolver2 =
   if resolver1 == resolver2 then
@@ -651,63 +488,54 @@ let add_delta_resolver resolver1 resolver2 =
   else if resolver2 = empty_delta_resolver then
     resolver1
   else
-    Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2)
-      resolver2
+    Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2
 
 let substition_prefixed_by k mp subst =
-  let prefixmp key (mp_to,reso) sub =
-    match key with 
-      | MPI mpk ->
-	  if mp_in_mp mp mpk && mp <> mpk then
-	    let new_key = replace_mp_in_mp mp k mpk in
-	      Umap.add (MPI new_key) (mp_to,reso) sub
-	  else 
-	    sub
-      |  _ -> sub
+  let mp_prefixmp kmp (mp_to,reso) sub =
+    if mp_in_mp mp kmp && mp <> kmp then
+      let new_key = replace_mp_in_mp mp k kmp in
+      Umap.add_mp new_key (mp_to,reso) sub
+    else sub
+  in
+  let mbi_prefixmp mbi _ sub = sub
   in
-    Umap.fold prefixmp subst empty_subst
+  Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst
 
-let join (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst key (mp,resolve) res =
+let join subst1 subst2 =
+  let apply_subst mpk add (mp,resolve) res =
     let mp',resolve' =
       match subst_mp0 subst2 mp with
-	  None -> mp, None
-	| Some (mp',resolve') ->  mp'
-	    ,Some resolve' in
-    let resolve'' : delta_resolver =
+	| None -> mp, None
+	| Some (mp',resolve') ->  mp', Some resolve' in
+    let resolve'' =
       match resolve' with
-          Some res -> 
-	    add_delta_resolver 
+        | Some res ->
+	    add_delta_resolver
 	      (subst_dom_codom_delta_resolver subst2 resolve) res
-	| None -> 
+	| None ->
 	    subst_codom_delta_resolver subst2 resolve
     in
-    let k = match key with MBI mp -> MPbound mp | MPI mp -> mp in
-    let prefixed_subst = substition_prefixed_by k mp subst2 in
-      Umap.fold Umap.add prefixed_subst 
-	(Umap.add key (mp',resolve'') res) in
-  let subst = Umap.fold apply_subst subst1 empty_subst in
-    (Umap.fold Umap.add subst2 subst)   
-
-
-
-let rec occur_in_path uid path =
- match uid,path with
-  | MBI bid,MPbound bid' -> bid = bid'
-  | _,MPdot (mp1,_) -> occur_in_path uid mp1
+    let prefixed_subst = substition_prefixed_by mpk mp' subst2 in
+    Umap.join prefixed_subst (add (mp',resolve'') res)
+  in
+  let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in
+  let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in
+  let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in
+  Umap.join subst2 subst
+
+let rec occur_in_path mbi = function
+  | MPbound bid' -> mbi = bid'
+  | MPdot (mp1,_) -> occur_in_path mbi mp1
   | _ -> false
 
-let occur_uid uid sub =
-  let check_one uid' (mp,_) =
-    if uid = uid' || occur_in_path uid mp then raise Exit
+let occur_mbid mbi sub =
+  let check_one mbi' (mp,_) =
+    if mbi = mbi' || occur_in_path mbi mp then raise Exit
   in
-    try
-      Umap.iter check_one sub;
-      false
-    with Exit -> true
-
-
-let occur_mbid uid = occur_uid (MBI uid)
+  try
+    Umap.iter_mbi check_one sub;
+    false
+  with Exit -> true
 
 type 'a lazy_subst =
   | LSval of 'a
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index 9b48b3ea..55d2ff15 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -1,105 +1,108 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_subst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s [Mod_subst] *)
+(** {6 [Mod_subst] } *)
 
 open Names
 open Term
 
-(* A delta_resolver maps name (constant, inductive, module_path) 
+(** {6 Delta resolver} *)
+
+(** A delta_resolver maps name (constant, inductive, module_path)
    to canonical name  *)
 type delta_resolver
 
-type substitution
-
 val empty_delta_resolver : delta_resolver
 
-val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver
+val add_mp_delta_resolver :
+  module_path -> module_path -> delta_resolver -> delta_resolver
 
-val add_inline_constr_delta_resolver :  constant -> constr -> delta_resolver 
-  -> delta_resolver
+val add_kn_delta_resolver :
+  kernel_name -> kernel_name -> delta_resolver -> delta_resolver
 
-val add_constant_delta_resolver : constant -> delta_resolver -> delta_resolver
-
-val add_mind_delta_resolver : mutual_inductive -> delta_resolver -> delta_resolver
-
-val add_mp_delta_resolver : module_path -> module_path -> delta_resolver 
-  -> delta_resolver
+val add_inline_delta_resolver :
+  kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver
 
 val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
 
-(* Apply the substitution on the domain of the resolver  *)
-val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *)
 
-(* Apply the substitution on the codomain of the resolver  *)
-val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver
-
-val subst_dom_codom_delta_resolver : 
-  substitution -> delta_resolver -> delta_resolver
-
-(* *_of_delta return the associated name of arg2 in arg1   *)
+val kn_of_delta : delta_resolver -> kernel_name -> kernel_name
+val constant_of_delta_kn : delta_resolver -> kernel_name -> constant
 val constant_of_delta : delta_resolver -> constant -> constant
 
+val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
 val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
 
-val delta_of_mp : delta_resolver -> module_path -> module_path
+val mp_of_delta : delta_resolver -> module_path -> module_path
 
-(* Extract the set of inlined constant in the resolver *)
-val inline_of_delta : delta_resolver -> kernel_name list
+(** Extract the set of inlined constant in the resolver *)
+val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list
 
-(* remove_mp is used for the computation of a resolver induced by Include P *)
-val remove_mp_delta_resolver : delta_resolver -> module_path -> delta_resolver
+(** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *)
 
-
-(* mem tests *)
 val mp_in_delta : module_path -> delta_resolver -> bool
-
 val con_in_delta : constant -> delta_resolver -> bool
-
 val mind_in_delta : mutual_inductive -> delta_resolver -> bool
 
-(*substitution*)
+
+(** {6 Substitution} *)
+
+type substitution
 
 val empty_subst : substitution
 
-(* add_* add [arg2/arg1]{arg3} to the substitution with no 
+val is_empty_subst : substitution -> bool
+
+(** add_* add [arg2/arg1]\{arg3\} to the substitution with no
    sequential composition  *)
 val add_mbid :
   mod_bound_id -> module_path -> delta_resolver  -> substitution -> substitution
 val add_mp :
   module_path -> module_path -> delta_resolver -> substitution -> substitution
 
-(* map_* create a new substitution [arg2/arg1]{arg3} *)
+(** map_* create a new substitution [arg2/arg1]\{arg3\} *)
 val map_mbid :
   mod_bound_id -> module_path -> delta_resolver -> substitution
 val map_mp :
   module_path -> module_path -> delta_resolver -> substitution
 
-(* sequential composition:
+(** sequential composition:
    [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
 *)
 val join : substitution -> substitution -> substitution
 
+
+(** Apply the substitution on the domain of the resolver  *)
+val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+
+(** Apply the substitution on the codomain of the resolver  *)
+val subst_codom_delta_resolver :
+  substitution -> delta_resolver -> delta_resolver
+
+val subst_dom_codom_delta_resolver :
+  substitution -> delta_resolver -> delta_resolver
+
+
 type 'a substituted
 val from_val : 'a -> 'a substituted
 val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a
 val subst_substituted : substitution -> 'a substituted -> 'a substituted
 
-(*i debugging *)
+(**/**)
+(* debugging *)
 val debug_string_of_subst : substitution -> string
 val debug_pr_subst : substitution -> Pp.std_ppcmds
 val debug_string_of_delta : delta_resolver -> string
 val debug_pr_delta : delta_resolver -> Pp.std_ppcmds
-(*i*)
+(**/**)
 
-(* [subst_mp sub mp] guarantees that whenever the result of the
+(** [subst_mp sub mp] guarantees that whenever the result of the
    substitution is structutally equal [mp], it is equal by pointers
    as well [==] *)
 
@@ -109,13 +112,13 @@ val subst_mp :
 val subst_ind :
   substitution -> mutual_inductive -> mutual_inductive
 
-val subst_kn : 
+val subst_kn :
   substitution -> kernel_name -> kernel_name
 
 val subst_con :
   substitution -> constant -> constant * constr
 
-(* Here the semantics is completely unclear.
+(** Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
    where X.t is later on instantiated with y? I choose the first
@@ -123,14 +126,14 @@ val subst_con :
 val subst_evaluable_reference :
   substitution -> evaluable_global_reference -> evaluable_global_reference
 
-(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
+(** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
 val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name
 
-(* [subst_mps sub c] performs the substitution [sub] on all kernel
+(** [subst_mps sub c] performs the substitution [sub] on all kernel
    names appearing in [c] *)
 val subst_mps : substitution -> constr -> constr
 
-(* [occur_*id id sub] returns true iff [id] occurs in [sub]
+(** [occur_*id id sub] returns true iff [id] occurs in [sub]
    on either side *)
 
 val occur_mbid : mod_bound_id -> substitution -> bool
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index e366bc97..a384c836 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -1,12 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module provides the main functions for type-checking module
+   declarations *)
 
 open Util
 open Names
@@ -25,18 +29,17 @@ let path_of_mexpr = function
   | MSEident mp -> mp
   | _ -> raise Not_path
 
+let rec mp_from_mexpr = function
+  | MSEident mp -> mp
+  | MSEapply (expr,_) -> mp_from_mexpr expr
+  | MSEfunctor (_,_,expr) -> mp_from_mexpr expr
+  | MSEwith (expr,_) -> mp_from_mexpr expr
+
 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 discr_resolver env mtb =
      match mtb.typ_expr with
 	SEBstruct _ -> 
@@ -81,40 +84,41 @@ and check_with_aux_def env sign with_decl mp equiv =
           | With_Definition ([],_) -> assert false
 	  | With_Definition ([id],c) ->
 	      let cb = match spec with
-		  SFBconst cb -> cb
+		| SFBconst cb -> cb
 		| _ -> error_not_a_constant l
 	      in
-		begin
-		  match cb.const_body with
-		    | None ->
-			let (j,cst1) = Typeops.infer env' c in
-			let typ = Typeops.type_of_constant_type env' cb.const_type in
-			let cst2 = Reduction.conv_leq env' j.uj_type typ in
-			let cst =
-			  Constraint.union
-			    (Constraint.union cb.const_constraints cst1)
-			    cst2 in
-			let body = Some (Declarations.from_val j.uj_val) in
-			let cb' = {cb with
-				     const_body = body;
-				     const_body_code = Cemitcodes.from_val
-                            (compile_constant_body env' body false false);
-                                     const_constraints = cst} in
-			  SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
-		    | Some b ->
-			let cst1 = Reduction.conv env' c (Declarations.force b) in
-			let cst = Constraint.union cb.const_constraints cst1 in
-			let body = Some (Declarations.from_val c) in
-			let cb' = {cb with
-				     const_body = body;
-				     const_body_code = Cemitcodes.from_val
-                            (compile_constant_body env' body false false);
-                                     const_constraints = cst} in
-			  SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
-	      end
+	      (* In the spirit of subtyping.check_constant, we accept
+                 any implementations of parameters and opaques terms,
+	         as long as they have the right type *)
+	      let def,cst = match cb.const_body with
+		| Undef _ | OpaqueDef _ ->
+		    let (j,cst1) = Typeops.infer env' c in
+		    let typ = Typeops.type_of_constant_type env' cb.const_type in
+		    let cst2 = Reduction.conv_leq env' j.uj_type typ in
+		    let cst =
+		      union_constraints
+			(union_constraints cb.const_constraints cst1)
+			cst2
+		    in
+		    let def = Def (Declarations.from_val j.uj_val) in
+		    def,cst
+		| Def cs ->
+		    let cst1 = Reduction.conv env' c (Declarations.force cs) in
+		    let cst = union_constraints cb.const_constraints cst1 in
+		    let def = Def (Declarations.from_val c) in
+		    def,cst
+	      in
+	      let cb' =
+		{ cb with
+		  const_body = def;
+		  const_body_code =
+		    Cemitcodes.from_val (compile_constant_body env' def);
+		  const_constraints = cst }
+	      in
+	      SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
 	  | With_Definition (_::_,c) ->
 	      let old = match spec with
-		  SFBmodule msb -> msb
+		| SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
 	      in
 		begin
@@ -129,12 +133,12 @@ and check_with_aux_def env sign with_decl mp equiv =
 						    mod_type_alg = None}) in
 			  SEBstruct(before@((l,new_spec)::after)),cb,cst
                     | Some msb ->
-			error_a_generative_module_expected l
+			error_generative_module_expected l
 		end
 	  | _ -> anomaly "Modtyping:incorrect use of with"
     with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
+      | Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_incorrect_with_constraint l
 
 and check_with_aux_mod env sign with_decl mp equiv = 
   let sig_b = match sign with 
@@ -163,24 +167,24 @@ and check_with_aux_mod env sign with_decl mp equiv =
 	      in
 	      let mb_mp1 = (lookup_module mp1 env) in
 	      let mtb_mp1 = 
-		module_type_of_module env' None mb_mp1  in
+		module_type_of_module None mb_mp1  in
 	      let cst =
 		match old.mod_expr with
 		    None ->
 		      begin
-			try Constraint.union
+			try union_constraints
 			  (check_subtypes env' mtb_mp1 
-			     (module_type_of_module env' None old))
+			     (module_type_of_module None old))
 			  old.mod_constraints
-			with Failure _ -> error_with_incorrect (label_of_id id)
+			with Failure _ -> error_incorrect_with_constraint (label_of_id id)
 		      end
 		  | Some (SEBident(mp')) ->
 		      check_modpath_equiv env' mp1 mp';
 		      old.mod_constraints
-		  | _ ->  error_a_generative_module_expected l
+		  | _ ->  error_generative_module_expected l
+	      in
+	      let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false
 	      in
-	      let new_mb = strengthen_and_subst_mb mb_mp1
-		(MPdot(mp,l)) env false in
 	      let new_spec = SFBmodule {new_mb with 
 					  mod_mp = MPdot(mp,l);
 					  mod_expr = Some (SEBident mp1);
@@ -215,14 +219,14 @@ and check_with_aux_mod env sign with_decl mp equiv =
 		      let mpnew = rebuild_mp mp' (List.map label_of_id idl) in
 			check_modpath_equiv env' mpnew mp;
 			  SEBstruct(before@(l,spec)::after)
-			    ,equiv,Constraint.empty
+			    ,equiv,empty_constraint
 		  | _ ->
-		      error_a_generative_module_expected l
+		      error_generative_module_expected l
               end
 	  | _ -> anomaly "Modtyping:incorrect use of with"
     with
 	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
+      | Reduction.NotConvertible -> error_incorrect_with_constraint l
 
 and translate_module env mp inl me =
   match me.mod_entry_expr, me.mod_entry_type with
@@ -243,14 +247,14 @@ and translate_module env mp inl me =
 	let sign,alg1,resolver,cst2 =
 	  match me.mod_entry_type with
 	    | None ->
-		sign,None,resolver,Constraint.empty
+		sign,None,resolver,empty_constraint
 	    | Some mte ->
 		let mtb = translate_module_type env mp inl mte in
                 let cst = check_subtypes env
 		  {typ_mp = mp;
 		   typ_expr = sign;
 		   typ_expr_alg = None;
-		   typ_constraints = Constraint.empty;
+		   typ_constraints = empty_constraint;
 		   typ_delta = resolver;}
 		  mtb
 		in
@@ -258,9 +262,9 @@ and translate_module env mp inl me =
 	in
 	  { mod_mp = mp;
 	    mod_type = sign;
-	    mod_expr = Some alg_implem;
+	    mod_expr = alg_implem;
 	    mod_type_alg = alg1;
-	    mod_constraints = Univ.Constraint.union cst1 cst2;
+	    mod_constraints = Univ.union_constraints cst1 cst2;
 	    mod_delta = resolver;
 	    mod_retroknowledge = []} 
 	    (* spiwack: not so sure about that. It may
@@ -268,125 +272,92 @@ and translate_module env mp inl me =
 	       If it does, I don't really know how to
 	       fix the bug.*)
 
+and translate_apply env inl ftrans mexpr mkalg =
+  let sign,alg,resolver,cst1 = ftrans in
+  let farg_id, farg_b, fbody_b = destr_functor env sign in
+  let mp1 =
+    try path_of_mexpr mexpr
+    with Not_path -> error_application_to_not_path mexpr
+  in
+  let mtb = module_type_of_module None (lookup_module mp1 env) in
+  let cst2 = check_subtypes env mtb farg_b in
+  let mp_delta = discr_resolver env mtb in
+  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
+  let subst = map_mbid farg_id mp1 mp_delta
+  in
+  subst_struct_expr subst fbody_b,
+  mkalg alg mp1 cst2,
+  subst_codom_delta_resolver subst resolver,
+  Univ.union_constraints cst1 cst2
+
+and translate_functor env inl arg_id arg_e trans mkalg =
+  let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
+  let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
+  let sign,alg,resolver,cst = trans env'
+  in
+  SEBfunctor (arg_id, mtb, sign),
+  mkalg alg arg_id mtb,
+  resolver,
+  Univ.union_constraints cst mtb.typ_constraints
 
-and translate_struct_module_entry env mp inl mse  = match mse with
+and translate_struct_module_entry env mp inl = function
   | MSEident mp1 ->
-      let mb = lookup_module mp1 env in 
-      let mb' = strengthen_and_subst_mb mb mp env false in
-	mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty
+      let mb = lookup_module mp1 env in
+      let mb' = strengthen_and_subst_mb mb mp false in
+      mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint
   | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
-      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) 
-	env in
-      let sign,alg,resolver,cst =
-	translate_struct_module_entry env' mp inl body_expr in
-      SEBfunctor (arg_id, mtb, sign),SEBfunctor (arg_id, mtb, alg),resolver,
-      Univ.Constraint.union cst mtb.typ_constraints
+      let trans env' = translate_struct_module_entry env' mp inl body_expr in
+      let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in
+      translate_functor env inl arg_id arg_e trans mkalg
   | MSEapply (fexpr,mexpr) ->
-      let sign,alg,resolver,cst1 =
-	translate_struct_module_entry env mp inl fexpr
-      in
-      let farg_id, farg_b, fbody_b = destr_functor env sign in
-      let mtb,mp1 = 
-	try
-	  let mp1 = path_of_mexpr mexpr in
-	      let mtb = module_type_of_module env None (lookup_module mp1 env) in
-		mtb,mp1
-	with
-	  | Not_path -> error_application_to_not_path mexpr
-	      (* place for nondep_supertype *) in
-      let cst = check_subtypes env mtb farg_b in
-      let mp_delta = discr_resolver env mtb in
-      let mp_delta = if not inl then mp_delta else
-	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
-      in
-      let subst = map_mbid farg_id mp1 mp_delta in
-	(subst_struct_expr subst fbody_b),SEBapply(alg,SEBident mp1,cst),
-      (subst_codom_delta_resolver subst resolver),
-      Univ.Constraint.union cst1 cst
+      let trans = translate_struct_module_entry env mp inl fexpr in
+      let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in
+      translate_apply env inl trans mexpr mkalg
   | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in
-      let sign,alg,resolve,cst2 = check_with env sign with_decl (Some alg) mp resolve in
-	sign,Option.get alg,resolve,Univ.Constraint.union cst1 cst2
-	  
-and translate_struct_type_entry env inl mse = match mse with
+      let sign,alg,resolve,cst1 =
+	translate_struct_module_entry env mp inl mte in
+      let sign,alg,resolve,cst2 =
+	check_with env sign with_decl alg mp resolve in
+      sign,alg,resolve,Univ.union_constraints cst1 cst2
+
+and translate_struct_type_entry env inl = function
   | MSEident mp1 ->
-      let mtb = lookup_modtype mp1 env in 
-	mtb.typ_expr,
-      Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty
+      let mtb = lookup_modtype mp1 env in
+      mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint
   | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
-      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env  in
-      let sign,alg,resolve,mp_from,cst =
-	translate_struct_type_entry env' inl body_expr in
-	SEBfunctor (arg_id, mtb, sign),None,resolve,mp_from,
-      Univ.Constraint.union cst mtb.typ_constraints
+      let trans env' = translate_struct_type_entry env' inl body_expr in
+      translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None)
   | MSEapply (fexpr,mexpr) ->
-      let sign,alg,resolve,mp_from,cst1 =
-	translate_struct_type_entry env inl fexpr
-      in
-      let farg_id, farg_b, fbody_b = destr_functor env sign in
-      let mtb,mp1 = 
-	try
-	  let mp1 = path_of_mexpr mexpr in
-	  let mtb = module_type_of_module env None (lookup_module mp1 env) in
-	    mtb,mp1
-	with
-	  | Not_path -> error_application_to_not_path mexpr
-	      (* place for nondep_supertype *) in
-      let cst2 = check_subtypes env mtb farg_b in
-      let mp_delta = discr_resolver env mtb in
-      let mp_delta = if not inl then mp_delta else
-	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
-      in
-      let subst = map_mbid farg_id mp1 mp_delta in
-	(subst_struct_expr subst fbody_b),None,
-      (subst_codom_delta_resolver subst resolve),mp_from,Univ.Constraint.union cst1 cst2
+      let trans = translate_struct_type_entry env inl fexpr in
+      translate_apply env inl trans mexpr (fun _ _ _ -> None)
   | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
-      let sign,alg,resolve,cst1 = 
-	check_with env sign with_decl alg mp_from resolve in
-	sign,alg,resolve,mp_from,Univ.Constraint.union cst cst1    
+      let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in
+      let sign,alg,resolve,cst2 =
+	check_with env sign with_decl alg (mp_from_mexpr mte) resolve
+      in
+      sign,alg,resolve,Univ.union_constraints cst1 cst2
 
 and translate_module_type env mp inl mte =
-	let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
-	let mtb = subst_modtype_and_resolver
-	  {typ_mp = mp_from;
-	   typ_expr = sign;
-	   typ_expr_alg = None;
-	   typ_constraints = cst;
-	   typ_delta = resolve} mp env
-	in {mtb with typ_expr_alg = alg}
+  let mp_from = mp_from_mexpr mte in
+  let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
+  let mtb = subst_modtype_and_resolver
+    {typ_mp = mp_from;
+     typ_expr = sign;
+     typ_expr_alg = None;
+     typ_constraints = cst;
+     typ_delta = resolve} mp
+  in {mtb with typ_expr_alg = alg}
 
-let rec translate_struct_include_module_entry env mp inl mse  = match mse with
+let rec translate_struct_include_module_entry env mp inl = function
   | MSEident mp1 ->
-      let mb = lookup_module mp1 env in 
-      let mb' = strengthen_and_subst_mb mb mp env true in
-      let mb_typ = clean_bounded_mod_expr mb'.mod_type in 
-	mb_typ, mb'.mod_delta,Univ.Constraint.empty
+      let mb = lookup_module mp1 env in
+      let mb' = strengthen_and_subst_mb mb mp true in
+      let mb_typ = clean_bounded_mod_expr mb'.mod_type in
+      mb_typ,None,mb'.mod_delta,Univ.empty_constraint
   | MSEapply (fexpr,mexpr) ->
-      let sign,resolver,cst1 =
-	translate_struct_include_module_entry env mp inl fexpr in
-      let farg_id, farg_b, fbody_b = destr_functor env sign in
-      let mtb,mp1 = 
-	try
-	  let mp1 = path_of_mexpr mexpr in
-	      let mtb = module_type_of_module env None (lookup_module mp1 env) in
-		mtb,mp1
-	with
-	  | Not_path -> error_application_to_not_path mexpr
-	      (* place for nondep_supertype *) in
-      let cst = check_subtypes env mtb farg_b in
-      let mp_delta =  discr_resolver env mtb in
-      let mp_delta = if not inl then mp_delta else
-	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
-      in
-      let subst = map_mbid farg_id mp1 mp_delta in
-	(subst_struct_expr subst fbody_b),
-      (subst_codom_delta_resolver subst resolver),
-      Univ.Constraint.union cst1 cst
+      let ftrans = translate_struct_include_module_entry env mp inl fexpr in
+      translate_apply env inl ftrans mexpr (fun _ _ _ -> None)
   | _ -> error ("You cannot Include a high-order structure.")
-  
 
 let rec add_struct_expr_constraints env = function
   | SEBident _ -> env
@@ -448,11 +419,11 @@ let rec struct_expr_constraints cst = function
 
   | SEBapply (meb1,meb2,cst1) ->
       struct_expr_constraints
-	(struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
+	(struct_expr_constraints (Univ.union_constraints cst1 cst) meb1)
 	meb2
   | SEBwith(meb,With_definition_body(_,cb))->
       struct_expr_constraints
-        (Univ.Constraint.union cb.const_constraints cst) meb
+        (Univ.union_constraints cb.const_constraints cst) meb
   | SEBwith(meb,With_module_body(_,_))->
       struct_expr_constraints  cst meb	
 		
@@ -468,11 +439,11 @@ and module_constraints cst mb =
     | Some meb -> struct_expr_constraints cst meb in
   let cst = 
       struct_expr_constraints cst mb.mod_type in
-  Univ.Constraint.union mb.mod_constraints cst
+  Univ.union_constraints mb.mod_constraints cst
 
 and modtype_constraints cst mtb =
-  struct_expr_constraints  (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr
+  struct_expr_constraints  (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr
 
 
-let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty
-let module_constraints = module_constraints Univ.Constraint.empty
+let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint
+let module_constraints = module_constraints Univ.empty_constraint
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index ec5eb332..0987ca5b 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -1,36 +1,44 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Declarations
 open Environ
 open Entries
 open Mod_subst
 open Names
-(*i*)
-
-
-val translate_module : env -> module_path -> bool -> module_entry
-  -> module_body
-
-val translate_module_type : env -> module_path -> bool -> module_struct_entry ->
-  module_type_body
-
-val translate_struct_module_entry : env -> module_path -> bool -> module_struct_entry ->
-  struct_expr_body * struct_expr_body * delta_resolver * Univ.constraints
 
-val translate_struct_type_entry : env -> bool -> module_struct_entry ->
-  struct_expr_body * struct_expr_body option * delta_resolver * module_path * Univ.constraints
 
-val translate_struct_include_module_entry : env -> module_path 
-  -> bool -> module_struct_entry -> struct_expr_body * delta_resolver * Univ.constraints
+val translate_module :
+  env -> module_path -> inline -> module_entry -> module_body
+
+val translate_module_type :
+  env -> module_path -> inline -> module_struct_entry -> module_type_body
+
+val translate_struct_module_entry :
+  env -> module_path -> inline -> module_struct_entry ->
+  struct_expr_body (* Signature *)
+  * struct_expr_body option  (* Algebraic expr, in fact never None *)
+  * delta_resolver
+  * Univ.constraints
+
+val translate_struct_type_entry :
+  env -> inline -> module_struct_entry ->
+  struct_expr_body
+  * struct_expr_body option
+  * delta_resolver
+  * Univ.constraints
+
+val translate_struct_include_module_entry :
+  env -> module_path -> inline -> module_struct_entry ->
+  struct_expr_body
+  * struct_expr_body option (* Algebraic expr, always None *)
+  * delta_resolver
+  * Univ.constraints
 
 val add_modtype_constraints : env -> module_type_body -> env
 
diff --git a/kernel/modops.ml b/kernel/modops.ml
index f0d579a4..0c2c6bd7 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -1,14 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+(* Inlining and more liberal use of modules and module types by Claudio
+   Sacerdoti, Nov 2004 *)
+(* New structure-based model of modules and miscellaneous bug fixes by
+   Élie Soubiran, from Feb 2008 *)
+
+(* This file provides with various operations on modules and module types *)
 
-(*i*)
 open Util
 open Pp
 open Names
@@ -18,80 +24,103 @@ open Declarations
 open Environ
 open Entries
 open Mod_subst
-(*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 "Non 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 () = 
-  error "The result module type must be a signature."
+type signature_mismatch_error =
+  | InductiveFieldExpected of mutual_inductive_body
+  | DefinitionFieldExpected
+  | ModuleFieldExpected
+  | ModuleTypeFieldExpected
+  | NotConvertibleInductiveField of identifier
+  | NotConvertibleConstructorField of identifier
+  | NotConvertibleBodyField
+  | NotConvertibleTypeField
+  | NotSameConstructorNamesField
+  | NotSameInductiveNameInBlockField
+  | FiniteInductiveFieldExpected of bool
+  | InductiveNumbersFieldExpected of int
+  | InductiveParamsNumberField of int
+  | RecordFieldExpected of bool
+  | RecordProjectionsExpected of name list
+  | NotEqualInductiveAliases
+  | NoTypeConstraintExpected
+
+type module_typing_error =
+  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of label
+  | ApplicationToNotPath of module_struct_entry
+  | NotAFunctor of struct_expr_body
+  | IncompatibleModuleTypes of module_type_body * module_type_body
+  | NotEqualModulePaths of module_path * module_path
+  | NoSuchLabel of label
+  | IncompatibleLabels of label * label
+  | SignatureExpected of struct_expr_body
+  | NoModuleToEnd
+  | NoModuleTypeToEnd
+  | NotAModule of string
+  | NotAModuleType of string
+  | NotAConstant of label
+  | IncorrectWithConstraint of label
+  | GenerativeModuleExpected of label
+  | NonEmptyLocalContect of label option
+  | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
+
+let error_existing_label l =
+  raise (ModuleTypingError (LabelAlreadyDeclared l))
+
+let error_application_to_not_path mexpr =
+  raise (ModuleTypingError (ApplicationToNotPath mexpr))
+
+let error_not_a_functor mtb =
+  raise (ModuleTypingError (NotAFunctor mtb))
+
+let error_incompatible_modtypes mexpr1 mexpr2 =
+  raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2)))
+
+let error_not_equal_modpaths mp1 mp2 =
+  raise (ModuleTypingError (NotEqualModulePaths (mp1,mp2)))
+
+let error_signature_mismatch l spec why =
+  raise (ModuleTypingError (SignatureMismatch (l,spec,why)))
+
+let error_no_such_label l =
+  raise (ModuleTypingError (NoSuchLabel l))
+
+let error_incompatible_labels l l' =
+  raise (ModuleTypingError (IncompatibleLabels (l,l')))
 
 let error_signature_expected mtb =
-  error "Signature expected."
+  raise (ModuleTypingError (SignatureExpected mtb))
 
-let error_no_module_to_end _ = 
-  error "No open module to end."
+let error_no_module_to_end _ =
+  raise (ModuleTypingError NoModuleToEnd)
 
 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."))
+  raise (ModuleTypingError NoModuleTypeToEnd)
 
-let error_not_a_module_or_modtype_loc loc s =
-  user_err_loc (loc,"",str ("\""^s^"\" is not a module or module type."))
+let error_not_a_modtype s =
+  raise (ModuleTypingError (NotAModuleType s))
 
-let error_not_a_module s = error_not_a_module_loc dummy_loc s
+let error_not_a_module s =
+  raise (ModuleTypingError (NotAModule s))
 
-let error_not_a_constant l = 
-  error ("\""^(string_of_label l)^"\" is not a constant.")
+let error_not_a_constant l =
+  raise (ModuleTypingError (NotAConstant l))
 
-let error_with_incorrect l =
-  error ("Incorrect constraint for label \""^(string_of_label l)^"\".")
+let error_incorrect_with_constraint l =
+  raise (ModuleTypingError (IncorrectWithConstraint l))
 
-let error_a_generative_module_expected l =
-  error ("The module " ^ string_of_label l ^ " is not generative. Only " ^
-         "component of generative modules can be changed using the \"with\" " ^
-         "construct.")
-
-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_generative_module_expected l =
+  raise (ModuleTypingError (GenerativeModuleExpected l))
 
+let error_non_empty_local_context lo =
+  raise (ModuleTypingError (NonEmptyLocalContect lo))
 
 let error_no_such_label_sub l l1 =
-  error ("The field "^(string_of_label l)^" is missing in "^l1^".")
-
-let error_with_in_module _ = error "The syntax \"with\" is not allowed for modules."
+  raise (ModuleTypingError (LabelMissing (l,l1)))
 
-let error_application_to_module_type _ = error "Module application to a module type."
+(************************)
 
 let destr_functor env mtb =
   match mtb with
@@ -116,9 +145,9 @@ let check_modpath_equiv env mp1 mp2 =
   if mp1=mp2 then () else
     let mb1=lookup_module  mp1 env in
     let mb2=lookup_module mp2 env in
-      if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2)
+      if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2)
       then ()
-      else error_not_equal mp1 mp2
+      else error_not_equal_modpaths mp1 mp2
 	
 let rec subst_with_body sub = function
   | With_module_body(id,mp) ->
@@ -235,18 +264,13 @@ let add_retroknowledge mp =
 let rec add_signature mp sign resolver env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
-    let con = constant_of_kn kn in
-    let mind = mind_of_kn kn in
-      match elem with
-	| SFBconst cb -> 
-	    let con =  constant_of_delta resolver con in
-	      Environ.add_constant con cb env
-	| SFBmind mib -> 
-	    let mind =  mind_of_delta resolver mind in
-	    Environ.add_mind mind mib env
-	| SFBmodule mb -> add_module mb env
-	      (* adds components as well *)
-	| SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+    match elem with
+      | SFBconst cb ->
+	Environ.add_constant (constant_of_delta_kn resolver kn) cb env
+      | SFBmind mib ->
+	Environ.add_mind (mind_of_delta_kn resolver kn) mib env
+      | SFBmodule mb -> add_module mb env (* adds components as well *)
+      | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
   in
     List.fold_left add_one env sign
 
@@ -260,100 +284,83 @@ and add_module mb env =
       | SEBfunctor _ -> env
       | _ -> anomaly "Modops:the evaluation of the structure failed "
 
-let strengthen_const env mp_from l cb resolver = 
-  match cb.const_opaque, cb.const_body with
-  | false, Some _ -> cb
-  | true, Some _ 
-  | _, None ->
-      let con = make_con mp_from empty_dirpath l in
-      let con =  constant_of_delta resolver con in
-      let const = mkConst con in 
-      let const_subs = Some (Declarations.from_val const) in
-	{cb with 
-	   const_body = const_subs;
-	   const_opaque = false;
-	   const_body_code = Cemitcodes.from_val
-            (compile_constant_body env const_subs false false)
-	}
-	  
-
-let rec strengthen_mod env mp_from mp_to mb = 
+let strengthen_const mp_from l cb resolver =
+  match cb.const_body with
+    | Def _ -> cb
+    | _ ->
+      let kn = make_kn mp_from empty_dirpath l in
+      let con = constant_of_delta_kn resolver kn in
+      { cb with
+	const_body = Def (Declarations.from_val (mkConst con));
+	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con)
+      }
+
+let rec strengthen_mod mp_from mp_to mb =
   if mp_in_delta mb.mod_mp mb.mod_delta then
-    mb 
+    mb
   else
     match mb.mod_type with
-     | SEBstruct (sign) -> 
-	 let resolve_out,sign_out = 
-	   strengthen_sig env mp_from sign mp_to mb.mod_delta in
+     | SEBstruct (sign) ->
+	 let resolve_out,sign_out =
+	   strengthen_sig mp_from sign mp_to mb.mod_delta in
 	   { mb with
 	       mod_expr = Some (SEBident mp_to);
 	       mod_type = SEBstruct(sign_out);
 	       mod_type_alg = mb.mod_type_alg;
 	       mod_constraints = mb.mod_constraints;
-	       mod_delta = add_mp_delta_resolver mp_from mp_to 
+	       mod_delta = add_mp_delta_resolver mp_from mp_to
 	       (add_delta_resolver mb.mod_delta resolve_out);
 	       mod_retroknowledge = mb.mod_retroknowledge}
      | SEBfunctor _ -> mb
      | _ -> anomaly "Modops:the evaluation of the structure failed "
-	 
-and strengthen_sig env mp_from sign mp_to resolver =
+
+and strengthen_sig mp_from sign mp_to resolver =
   match sign with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = 
-	  l,SFBconst (strengthen_const env mp_from l cb resolver) in
-	let resolve_out,rest' =
-	  strengthen_sig env mp_from rest mp_to resolver in
-	  resolve_out,item'::rest'
+	let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item'::rest'
     | (_,SFBmind _ as item):: rest ->
-	let resolve_out,rest' = 
-	  strengthen_sig env mp_from rest mp_to resolver in
-	  resolve_out,item::rest'
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in 
-	let mb_out = 
-	  strengthen_mod env mp_from' mp_to' mb in
+	let mp_to' = MPdot(mp_to,l) in
+	let mb_out = strengthen_mod mp_from' mp_to' mb in
 	let item' = l,SFBmodule (mb_out) in
-	let env' = add_module mb_out env in
-	let resolve_out,rest' = 
-	  strengthen_sig env' mp_from rest mp_to resolver in
-	  add_delta_resolver resolve_out mb.mod_delta,
-	item':: rest'
-    | (l,SFBmodtype mty as item) :: rest -> 
-	let env' = add_modtype 
-	  (MPdot(mp_from,l)) mty env
-	in
-	let resolve_out,rest' = 
-	  strengthen_sig env' mp_from rest mp_to resolver in
-	  resolve_out,item::rest'
-    
-let strengthen env mtb mp = 
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	add_delta_resolver resolve_out mb.mod_delta, item':: rest'
+    | (l,SFBmodtype mty as item) :: rest ->
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item::rest'
+
+let strengthen mtb mp =
   if mp_in_delta mtb.typ_mp mtb.typ_delta then
     (* in this case mtb has already been strengthened*)
-    mtb 
+    mtb
   else
     match mtb.typ_expr with
-      | SEBstruct (sign) -> 
+      | SEBstruct (sign) ->
 	  let resolve_out,sign_out =
-	    strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in
+	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
 	    {mtb with
 	       typ_expr = SEBstruct(sign_out);
 	       typ_delta = add_delta_resolver mtb.typ_delta
 		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
       | SEBfunctor _ -> mtb
       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	  
-let module_type_of_module env mp mb =
+
+let module_type_of_module mp mb =
   match mp with
       Some mp ->
-	strengthen env {
+	strengthen {
 	  typ_mp = mp;
 	  typ_expr = mb.mod_type;
 	  typ_expr_alg = None;
 	  typ_constraints = mb.mod_constraints;
 	  typ_delta = mb.mod_delta} mp
-	  
+
     | None ->
 	{typ_mp = mb.mod_mp;
 	 typ_expr = mb.mod_type;
@@ -361,34 +368,29 @@ let module_type_of_module env mp mb =
 	 typ_constraints = mb.mod_constraints;
 	 typ_delta = mb.mod_delta}
 
-let complete_inline_delta_resolver env mp mbid mtb delta =
-  let constants = inline_of_delta mtb.typ_delta in
+let inline_delta_resolver env inl mp mbid mtb delta =
+  let constants = inline_of_delta inl mtb.typ_delta in
   let rec make_inline delta = function
     | [] -> delta
-    | kn::r -> 
+    | (lev,kn)::r ->
 	let kn = replace_mp_in_kn (MPbound mbid) mp kn in
-	let con = constant_of_kn kn in
-	let con' = constant_of_delta delta con in
-	  try
-	    let constant = lookup_constant con' env in
-	      if (not constant.Declarations.const_opaque) then
-		let constr = Option.map Declarations.force 
-		  constant.Declarations.const_body in
-		  if constr = None then 
-		    (make_inline delta r)
-		  else
-		    add_inline_constr_delta_resolver con (Option.get constr)
-		      (make_inline delta r)
-	      else
-		(make_inline delta r)
-	  with 
-	      Not_found -> error_no_such_label_sub (con_label con) 
-		(string_of_mp (con_modpath con))
+	let con = constant_of_delta_kn delta kn in
+	try
+	  let constant = lookup_constant con env in
+	  let l = make_inline delta r in
+	  match constant.const_body with
+	    | Undef _ | OpaqueDef _ -> l
+	    | Def body ->
+	      let constr = Declarations.force body in
+	      add_inline_delta_resolver kn (lev, Some constr) l
+	with Not_found ->
+	  error_no_such_label_sub (con_label con)
+	    (string_of_mp (con_modpath con))
   in
-    make_inline delta constants
+  make_inline delta constants
 
 let rec strengthen_and_subst_mod
-    mb subst env mp_from mp_to env resolver =
+    mb subst mp_from mp_to resolver =
      match mb.mod_type with
 	 SEBstruct(str) ->
 	   let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
@@ -397,7 +399,7 @@ let rec strengthen_and_subst_mod
 	       (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb 
 	   else
 	     let resolver,new_sig = 
-	       strengthen_and_subst_struct str subst env
+	       strengthen_and_subst_struct str subst
 		 mp_from mp_from mp_to false false mb.mod_delta 
 	     in
 	       {mb with 
@@ -413,42 +415,48 @@ let rec strengthen_and_subst_mod
        | _ -> anomaly "Modops:the evaluation of the structure failed "
 	   
 and strengthen_and_subst_struct 
-    str subst env mp_alias mp_from mp_to alias incl resolver =
+    str subst mp_alias mp_from mp_to alias incl resolver =
   match str with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = if alias then
+	let item' = if alias then 
+	  (* case alias no strengthening needed*)
 	  l,SFBconst (subst_const_body subst cb) 
 	else 
-	  l,SFBconst (strengthen_const env mp_from l 
+	  l,SFBconst (strengthen_const mp_from l
 			(subst_const_body subst cb) resolver)
 	in
-	let con = make_con mp_from empty_dirpath l in
 	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst env 
+	  strengthen_and_subst_struct rest subst
 	    mp_alias mp_from mp_to alias incl resolver in
-	  if incl then
-	    let old_name = constant_of_delta resolver con in
-	    (add_constant_delta_resolver
-	      (constant_of_kn_equiv (make_kn mp_to empty_dirpath l)
-		 (canonical_con old_name)) 
-	      resolve_out),
-	item'::rest'
-	  else
-	    resolve_out,item'::rest'
+	if incl then
+	    (* If we are performing an inclusion we need to add
+	       the fact that the constant mp_to.l is \Delta-equivalent
+	       to resolver(mp_from.l) *)
+	  let kn_from = make_kn mp_from empty_dirpath l in
+	  let kn_to = make_kn mp_to empty_dirpath l in
+	  let old_name = kn_of_delta resolver kn_from in
+	  (add_kn_delta_resolver kn_to old_name resolve_out),
+	  item'::rest'
+	else
+	    (*In this case the fact that the constant mp_to.l is 
+	      \Delta-equivalent to resolver(mp_from.l) is already known
+	       because resolve_out contains mp_to maps to resolver(mp_from)*)
+	  resolve_out,item'::rest'
     | (l,SFBmind mib) :: rest ->
+	(*Same as constant*)
 	let item' = l,SFBmind (subst_mind subst mib) in
-	let mind = make_mind mp_from empty_dirpath l in
 	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst env 
+	  strengthen_and_subst_struct rest subst
 	    mp_alias mp_from mp_to alias incl resolver in
-	  if incl then
-	    let old_name =  mind_of_delta resolver mind in 
-	    (add_mind_delta_resolver
-	      (mind_of_kn_equiv (make_kn mp_to empty_dirpath l) (canonical_mind old_name)) resolve_out),
-	item'::rest'
-	  else
-	    resolve_out,item'::rest'
+	if incl then
+	  let kn_from = make_kn mp_from empty_dirpath l in
+	  let kn_to = make_kn mp_to empty_dirpath l in
+	  let old_name = kn_of_delta resolver kn_from in
+	  (add_kn_delta_resolver kn_to old_name resolve_out),
+	  item'::rest'
+	else
+	  resolve_out,item'::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
 	let mp_to' = MPdot(mp_to,l) in
@@ -457,15 +465,20 @@ and strengthen_and_subst_struct
 	  (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb 
 	else
 	  strengthen_and_subst_mod
-	    mb subst env mp_from' mp_to' env resolver
+	    mb subst mp_from' mp_to' resolver
 	in
 	let item' = l,SFBmodule (mb_out) in
-	let env' = add_module mb_out env in
-	let resolve_out,rest' = 
-	  strengthen_and_subst_struct rest subst env' 
+	let resolve_out,rest' =
+	  strengthen_and_subst_struct rest subst
 	    mp_alias mp_from mp_to alias incl resolver in
-	  if  is_functor mb_out.mod_type then (add_mp_delta_resolver 
-	     mp_to' mp_to' resolve_out),item':: rest' else
+	  (* if mb is a functor we should not derive new equivalences
+	     on names, hence we add the fact that the functor can only
+	     be equivalent to itself. If we adopt an applicative
+	     semantic for functor this should be changed.*)
+	  if is_functor mb_out.mod_type then 
+	    (add_mp_delta_resolver 
+	       mp_to' mp_to' resolve_out),item':: rest' 
+	  else
 	    add_delta_resolver resolve_out mb_out.mod_delta,
 	item':: rest'
     | (l,SFBmodtype mty) :: rest -> 
@@ -474,27 +487,30 @@ and strengthen_and_subst_struct
 	let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in
 	let mty = subst_modtype subst' 
 	  (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in
-	let env' = add_modtype mp_from' mty env	in
-	let resolve_out,rest' = strengthen_and_subst_struct rest subst env' 
+	let resolve_out,rest' = strengthen_and_subst_struct rest subst
 	    mp_alias mp_from mp_to alias incl resolver in
 	  (add_mp_delta_resolver 
 	     mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
     
-let strengthen_and_subst_mb mb mp env include_b =
+
+(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M."
+   we need to perform two operations to compute the body of M. The first one is applying
+   the substitution {P <- M} on the type of P and the second one is strenghtening. *)
+let strengthen_and_subst_mb mb mp include_b =
     match mb.mod_type with
 	SEBstruct str ->
 	  let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	    (*if mb is an alias then the strengthening is useless 
+	    (*if mb.mod_mp is an alias then the strengthening is useless 
 	      (i.e. it is already done)*)
-	  let mp_alias = delta_of_mp mb.mod_delta mb.mod_mp in
+	  let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
 	  let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
 	  let new_resolver = 
 	    add_mp_delta_resolver mp mp_alias
-	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in	    
+	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in
 	  let subst = map_mp mb.mod_mp mp new_resolver in 
 	  let resolver_out,new_sig = 
-	    strengthen_and_subst_struct str subst env
-	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
+	    strengthen_and_subst_struct str subst
+	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta 
 	  in
 	    {mb with 
 	       mod_mp = mp;
@@ -509,7 +525,7 @@ let strengthen_and_subst_mb mb mp env include_b =
       | _ -> anomaly "Modops:the evaluation of the structure failed "
 
 
-let subst_modtype_and_resolver mtb mp env =
+let subst_modtype_and_resolver mtb mp =
   let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
   let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in 
   let full_subst = (map_mp mtb.typ_mp mp new_delta) in
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 37f4e8e0..b9c36d5a 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Univ
@@ -16,14 +13,13 @@ open Environ
 open Declarations
 open Entries
 open Mod_subst
-(*i*)
 
-(* Various operations on modules and module types *)
+(** Various operations on modules and module types *)
 
 
 val module_body_of_type : module_path -> module_type_body  -> module_body 
 
-val module_type_of_module : env -> module_path option -> module_body -> 
+val module_type_of_module : module_path option -> module_body ->
   module_type_body
 
 val destr_functor :
@@ -36,71 +32,95 @@ val subst_signature : substitution -> structure_body -> structure_body
 val add_signature :
   module_path -> structure_body -> delta_resolver -> env -> env
 
-(* adds a module and its components, but not the constraints *)
+(** adds a module and its components, but not the constraints *)
 val add_module : 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 strengthen : module_type_body -> module_path -> module_type_body
 
-val complete_inline_delta_resolver :
-  env -> module_path -> mod_bound_id -> module_type_body ->
+val inline_delta_resolver :
+  env -> inline -> module_path -> mod_bound_id -> module_type_body ->
   delta_resolver -> delta_resolver
 
-val strengthen_and_subst_mb : module_body -> module_path -> env -> bool 
-  -> module_body
+val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
 
-val subst_modtype_and_resolver : module_type_body -> module_path -> env ->
+val subst_modtype_and_resolver : module_type_body -> module_path ->
   module_type_body
 
 val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
 
-val error_existing_label : label -> 'a
+(** Errors *)
+
+type signature_mismatch_error =
+  | InductiveFieldExpected of mutual_inductive_body
+  | DefinitionFieldExpected
+  | ModuleFieldExpected
+  | ModuleTypeFieldExpected
+  | NotConvertibleInductiveField of identifier
+  | NotConvertibleConstructorField of identifier
+  | NotConvertibleBodyField
+  | NotConvertibleTypeField
+  | NotSameConstructorNamesField
+  | NotSameInductiveNameInBlockField
+  | FiniteInductiveFieldExpected of bool
+  | InductiveNumbersFieldExpected of int
+  | InductiveParamsNumberField of int
+  | RecordFieldExpected of bool
+  | RecordProjectionsExpected of name list
+  | NotEqualInductiveAliases
+  | NoTypeConstraintExpected
+
+type module_typing_error =
+  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of label
+  | ApplicationToNotPath of module_struct_entry
+  | NotAFunctor of struct_expr_body
+  | IncompatibleModuleTypes of module_type_body * module_type_body
+  | NotEqualModulePaths of module_path * module_path
+  | NoSuchLabel of label
+  | IncompatibleLabels of label * label
+  | SignatureExpected of struct_expr_body
+  | NoModuleToEnd
+  | NoModuleTypeToEnd
+  | NotAModule of string
+  | NotAModuleType of string
+  | NotAConstant of label
+  | IncorrectWithConstraint of label
+  | GenerativeModuleExpected of label
+  | NonEmptyLocalContect of label option
+  | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
 
-val error_declaration_not_path : module_struct_entry -> 'a
+val error_existing_label : label -> 'a
 
 val error_application_to_not_path : module_struct_entry -> 'a
 
-val error_not_a_functor :  module_struct_entry -> '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 -> structure_field_body -> 'a
+val error_signature_mismatch :
+  label -> structure_field_body -> signature_mismatch_error -> 'a
 
 val error_incompatible_labels : label -> label -> 'a
 
 val error_no_such_label : label -> 'a
 
-val error_result_must_be_signature : unit -> 'a
-
 val error_signature_expected : struct_expr_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_or_modtype_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_incorrect_with_constraint : label -> 'a
 
-val error_a_generative_module_expected : label -> 'a
+val error_generative_module_expected : label -> 'a
 
-val error_local_context : label option -> 'a
+val error_non_empty_local_context : label option -> 'a
 
 val error_no_such_label_sub : label->string->'a
-
-val error_with_in_module : unit -> 'a
-
-val error_application_to_module_type : unit -> 'a
-
diff --git a/kernel/names.ml b/kernel/names.ml
index 642f5562..ae8ad093 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -1,35 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* File created around Apr 1994 for CiC V5.10.5 by Chet Murthy collecting
+   parts of file initial.ml from CoC V4.8, Dec 1988, by Gérard Huet,
+   Thierry Coquand and Christine Paulin *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Extra functions for splitting/generation of identifiers by Hugo Herbelin *)
+(* Restructuration by Jacek Chrzaszcz as part of the implementation of
+   the module system, Aug 2002 *)
+(* Abstraction over the type of constant for module inlining by Claudio
+   Sacerdoti, Nov 2004 *)
+(* Miscellaneous features or improvements by Hugo Herbelin, 
+   Élie Soubiran, ... *)
 
 open Pp
 open Util
 
-(*s Identifiers *)
+(** {6 Identifiers } *)
 
 type identifier = string
 
-let id_ord = Pervasives.compare
-
 let id_of_string s = check_ident_soft s; String.copy s
-
 let string_of_id id = String.copy 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)
+let id_ord = Pervasives.compare
 
 module IdOrdered =
   struct
@@ -38,15 +37,27 @@ module IdOrdered =
   end
 
 module Idset = Set.Make(IdOrdered)
-module Idmap = Map.Make(IdOrdered)
+module Idmap =
+struct
+  include Map.Make(IdOrdered)
+  exception Finded
+  let exists f m =
+    try iter (fun a b -> if f a b then raise Finded) m ; false
+    with |Finded -> true
+  let singleton k v = add k v empty
+end
 module Idpred = Predicate.Make(IdOrdered)
 
-(* Names *)
+(** {6 Various types based on identifiers } *)
 
 type name = Name of identifier | Anonymous
+type variable = identifier
 
-(* Dirpaths are lists of module identifiers. The actual representation
-   is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
+(** {6 Directory paths = section names paths } *)
+
+(** 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
@@ -58,14 +69,17 @@ let repr_dirpath x = x
 
 let empty_dirpath = []
 
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
+
 let string_of_dirpath = function
   | [] -> "<>"
   | sl -> String.concat "." (List.map string_of_id (List.rev sl))
 
+(** {6 Unique names for bound modules } *)
 
 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)
+type uniq_ident = int * identifier * dir_path
+let make_uid dir s = incr u_number;(!u_number,s,dir)
  let debug_string_of_uid (i,s,p) =
  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
 let string_of_uid (i,s,p) =
@@ -76,30 +90,31 @@ module Umap = Map.Make(struct
 			 let compare = Pervasives.compare
 		       end)
 
-type label = string
-
 type mod_bound_id = uniq_ident
 let make_mbid = make_uid
 let repr_mbid (n, id, dp) = (n, id, dp)
 let debug_string_of_mbid = debug_string_of_uid
 let string_of_mbid = string_of_uid
 let id_of_mbid (_,s,_) = s
-let label_of_mbid (_,s,_) = s
 
+(** {6 Names of structure elements } *)
 
-let mk_label l = l
-let string_of_label = string_of_id
+type label = identifier
 
+let mk_label = id_of_string
+let string_of_label = string_of_id
+let pr_label l = str (string_of_label l)
 let id_of_label l = l
 let label_of_id id = id
 
 module Labset = Idset
 module Labmap = Idmap
 
+(** {6 The module part of the kernel name } *)
+
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
- (* | MPapp of module_path * module_path *)
   | MPdot of module_path * label
 
 let rec check_bound_mp = function
@@ -110,12 +125,9 @@ let rec check_bound_mp = function
 let rec string_of_mp = function
   | MPfile sl -> string_of_dirpath sl
   | MPbound uid -> string_of_uid uid
- (* | MPapp (mp1,mp2) -> 
-      "("^string_of_mp mp ^ " " ^ 
-	string_of_mp mp^")"*)
   | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
 
-(* we compare labels first if both are MPdots *)
+(** 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
@@ -133,7 +145,12 @@ end
 module MPset = Set.Make(MPord)
 module MPmap = Map.Make(MPord)
 
-(* Kernel names *)
+let default_module_name = "If you see this, it's a bug"
+
+let initial_dir = make_dirpath [default_module_name]
+let initial_path = MPfile initial_dir
+
+(** {6 Kernel names } *)
 
 type kernel_name = module_path * dir_path * label
 
@@ -147,11 +164,12 @@ 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 str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#"
+  in
+  string_of_mp mp ^ str_dir ^ string_of_label l
 
 let pr_kn kn = str (string_of_kn kn)
 
-
 let kn_ord kn1 kn2 =
     let mp1,dir1,l1 = kn1 in
     let mp2,dir2,l2 = kn2 in
@@ -165,87 +183,84 @@ let kn_ord kn1 kn2 =
 	  else
 	    MPord.compare mp1 mp2
 
-(* a constant name is a kernel name couple (kn1,kn2) 
+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)
+
+(** {6 Constant names } *)
+
+(** a constant name is a kernel name couple (kn1,kn2)
    where kn1 corresponds to the name used at toplevel
-   (i.e. what the user see) 
-   and kn2 corresponds to the canonical kernel name 
-   i.e. in the environment we have 
+   (i.e. what the user see)
+   and kn2 corresponds to the canonical kernel name
+   i.e. in the environment we have
    kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *)
 type constant = kernel_name*kernel_name
 
-(* For the environment we distinguish constants by their 
-   user part*)
+let constant_of_kn kn = (kn,kn)
+let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
+let make_con mp dir l = constant_of_kn (mp,dir,l)
+let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let canonical_con con = snd con
+let user_con con = fst con
+let repr_con con = fst con
+
+let eq_constant (_,kn1) (_,kn2) = kn1=kn2
+
+let con_label con = label (fst con)
+let con_modpath con = modpath (fst con)
+
+let string_of_con con = string_of_kn (fst con)
+let pr_con con = str (string_of_con con)
+let debug_string_of_con con =
+  "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
+let debug_pr_con con = str (debug_string_of_con con)
+
+let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
+  if lbl = l1 && lbl = l2 then con
+  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
+
+(** For the environment we distinguish constants by their user part*)
 module User_ord = struct
   type t = kernel_name*kernel_name
   let compare x y= kn_ord (fst x) (fst y)
 end
 
-(* For other uses (ex: non-logical things) it is enough
-   to deal with the canonical part *)
+(** For other uses (ex: non-logical things) it is enough
+    to deal with the canonical part *)
 module Canonical_ord = struct
   type t = kernel_name*kernel_name
   let compare x y= kn_ord (snd x) (snd y)
 end
 
-
-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)
-
 module Cmap = Map.Make(Canonical_ord)
 module Cmap_env = Map.Make(User_ord)
 module Cpred = Predicate.Make(Canonical_ord)
 module Cset = Set.Make(Canonical_ord)
 module Cset_env = Set.Make(User_ord)
 
-module Mindmap = Map.Make(Canonical_ord)
-module Mindset = Set.Make(Canonical_ord)
-module Mindmap_env = Map.Make(User_ord)
-
-let default_module_name = "If you see this, it's a bug"
 
-let initial_dir = make_dirpath [default_module_name]
-let initial_path = MPfile initial_dir
+(** {6 Names of mutual inductive types } *)
 
-type variable = identifier
+(** The same thing is done for mutual inductive names
+    it replaces also the old mind_equiv field of mutual
+    inductive types *)
+(** Beware: first inductive has index 0 *)
+(** Beware: first constructor has index 1 *)
 
-(* The same thing is done for mutual inductive names 
-   it replaces also the old mind_equiv field of mutual 
-   inductive types*)
 type mutual_inductive = kernel_name*kernel_name
 type inductive = mutual_inductive * int
 type constructor = inductive * int
 
-let constant_of_kn kn = (kn,kn)
-let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_con mp dir l = constant_of_kn (mp,dir,l)
-let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
-let canonical_con con = snd con
-let user_con con = fst con
-let repr_con con = fst con
-let string_of_con con = string_of_kn (fst con)
-let con_label con = label (fst con)
-let pr_con con = pr_kn (fst con)
-let debug_pr_con con = str "("++ pr_kn (fst con) ++ str ","++ pr_kn (snd con)++ str ")"
-let eq_constant (_,kn1) (_,kn2) = kn1=kn2
-let debug_string_of_con con =  string_of_kn (fst con)^"'"^string_of_kn (snd con)
-
-let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
-  if lbl = l1 && lbl = l2 then con
-  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
-
-let con_modpath con = modpath (fst con)
-
 let mind_modpath mind = modpath (fst mind)
 let ind_modpath ind = mind_modpath (fst ind)
 let constr_modpath c = ind_modpath (fst c)
 
-
 let mind_of_kn kn = (kn,kn)
 let mind_of_kn_equiv kn1 kn2 = (kn1,kn2)
 let make_mind mp dir l = ((mp,dir,l),(mp,dir,l))
@@ -253,12 +268,15 @@ let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
 let canonical_mind mind = snd mind
 let user_mind mind = fst mind
 let repr_mind mind = fst mind
-let string_of_mind mind = string_of_kn (fst mind)
 let mind_label mind= label (fst mind)
-let pr_mind mind = pr_kn (fst mind)
-let debug_pr_mind mind = str "("++ pr_kn (fst mind) ++ str ","++ pr_kn (snd mind)++ str ")"
+
 let eq_mind (_,kn1) (_,kn2) = kn1=kn2
-let debug_string_of_mind mind =  string_of_kn (fst mind)^"'"^string_of_kn (snd mind)
+
+let string_of_mind mind = string_of_kn (fst mind)
+let pr_mind mind = str (string_of_mind mind)
+let debug_string_of_mind mind =
+  "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")"
+let debug_pr_mind con = str (debug_string_of_mind con)
 
 let ith_mutual_inductive (kn,_) i = (kn,i)
 let ith_constructor_of_inductive ind i = (ind,i)
@@ -267,6 +285,10 @@ let index_of_constructor (ind,i) = i
 let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
 let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
 
+module Mindmap = Map.Make(Canonical_ord)
+module Mindset = Set.Make(Canonical_ord)
+module Mindmap_env = Map.Make(User_ord)
+
 module InductiveOrdered = struct
   type t = inductive
   let compare (spx,ix) (spy,iy) =
@@ -306,7 +328,8 @@ let eq_egr e1 e2 = match e1,e2 with
     EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
   | _,_ -> e1 = e2
 
-(* Hash-consing of name objects *)
+(** {6 Hash-consing of name objects } *)
+
 module Hname = Hashcons.Make(
   struct
     type t = name
@@ -326,7 +349,7 @@ module Hdir = Hashcons.Make(
   struct
     type t = dir_path
     type u = identifier -> identifier
-    let hash_sub hident d = List.map hident d
+    let hash_sub hident d = list_smartmap hident d
     let rec equal d1 d2 = match (d1,d2) with
       | [],[] -> true
       | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
@@ -337,9 +360,9 @@ module Hdir = Hashcons.Make(
 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
+    type u = (identifier -> identifier) * (dir_path -> dir_path)
+    let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
+    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2
     let hash = Hashtbl.hash
   end)
 
@@ -355,34 +378,66 @@ module Hmod = Hashcons.Make(
     let rec equal d1 d2 = match (d1,d2) with
       | MPfile dir1, MPfile dir2 -> dir1 == dir2
       | MPbound m1, MPbound m2 -> m1 == m2
-      | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
       | _ -> false
     let hash = Hashtbl.hash
   end)
 
-
-module Hcn = Hashcons.Make(
-  struct 
-    type t = kernel_name*kernel_name
+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),(mde,dire,le)) = 
-      ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le))
-    let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) =
+    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 hmind = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
-  let hcn = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
-  (hcn,hmind,hdir,hname,hident,hstring)
+(** For [constant] and [mutual_inductive], we discriminate only on
+    the user part : having the same user part implies having the
+    same canonical part (invariant of the system). *)
+
+module Hcn = Hashcons.Make(
+  struct
+    type t = kernel_name*kernel_name
+    type u = kernel_name -> kernel_name
+    let hash_sub hkn (user,can) = (hkn user, hkn can)
+    let equal (user1,_) (user2,_) = user1 == user2
+    let hash (user,_) = Hashtbl.hash user
+  end)
+
+module Hind = Hashcons.Make(
+  struct
+    type t = inductive
+    type u = mutual_inductive -> mutual_inductive
+    let hash_sub hmind (mind, i) = (hmind mind, i)
+    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2
+    let hash = Hashtbl.hash
+  end)
+
+module Hconstruct = Hashcons.Make(
+  struct
+    type t = constructor
+    type u = inductive -> inductive
+    let hash_sub hind (ind, j) = (hind ind, j)
+    let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2
+    let hash = Hashtbl.hash
+  end)
+
+let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f ()
+let hcons_ident = hcons_string
+let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident
+let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident
+let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath)
+let hcons_mp =
+  Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string)
+let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string)
+let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind
+let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind
 
 
 (*******)
diff --git a/kernel/names.mli b/kernel/names.mli
index 612851dd..34c5e62c 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -1,62 +1,59 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: names.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s Identifiers *)
+(** {6 Identifiers } *)
 
 type identifier
-type name = Name of identifier | Anonymous
-(* Parsing and printing of identifiers *)
+
+(** 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 *)
+(** 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
+module Idmap  : sig
+  include Map.S with type key = identifier
+  val exists : (identifier -> 'a -> bool) -> 'a t -> bool
+  val singleton : key -> 'a -> 'a t
+end
+
+(** {6 Various types based on identifiers } *)
+
+type name = Name of identifier | Anonymous
+type variable = identifier
+
+(** {6 Directory paths = section names paths } *)
 
-(*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).
+(** 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"] *)
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
 val string_of_dirpath : dir_path -> string
 
-type label
-
-(*s Unique names for bound modules *)
-type mod_bound_id
-
-(* The first argument is a file name - to prevent conflict between
-   different files *)
-val make_mbid : dir_path -> string -> mod_bound_id
-val repr_mbid : mod_bound_id -> int * string * dir_path
-val id_of_mbid : mod_bound_id -> identifier
-val label_of_mbid : mod_bound_id -> label
-val debug_string_of_mbid : mod_bound_id -> string
-val string_of_mbid : mod_bound_id -> string
+(** {6 Names of structure elements } *)
 
-(*s Names of structure elements *)
+type label
 
 val mk_label : string -> label
 val string_of_label : label -> string
+val pr_label : label -> Pp.std_ppcmds
 
 val label_of_id : identifier -> label
 val id_of_label : label -> identifier
@@ -64,14 +61,26 @@ 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 *)
+(** {6 Unique names for bound modules } *)
+
+type mod_bound_id
+
+(** The first argument is a file name - to prevent conflict between
+   different files *)
+
+val make_mbid : dir_path -> identifier -> mod_bound_id
+val repr_mbid : mod_bound_id -> int * identifier * dir_path
+val id_of_mbid : mod_bound_id -> identifier
+val debug_string_of_mbid : mod_bound_id -> string
+val string_of_mbid : mod_bound_id -> string
+
+(** {6 The module part of the kernel name } *)
+
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
- (* | MPapp of module_path * module_path  very soon *)
   | MPdot of module_path * label
 
-
 val check_bound_mp : module_path -> bool
 
 val string_of_mp : module_path -> string
@@ -79,17 +88,17 @@ 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
 
-(* Initial "seed" of the unique identifier generator *)
+(** Initial "seed" of the unique identifier generator *)
 val initial_dir : dir_path
 
-(* Name of the toplevel structure *)
-val initial_path : module_path (* [= MPfile initial_dir] *)
+(** Name of the toplevel structure *)
+val initial_path : module_path (** [= MPfile initial_dir] *)
 
-(*s The absolute names of objects seen by kernel *)
+(** {6 The absolute names of objects seen by kernel } *)
 
 type kernel_name
 
-(* Constructor and destructor *)
+(** Constructor and destructor *)
 val make_kn : module_path -> dir_path -> label -> kernel_name
 val repr_kn : kernel_name -> module_path * dir_path * label
 
@@ -99,23 +108,25 @@ val label : kernel_name -> label
 val string_of_kn : kernel_name -> string
 val pr_kn : kernel_name -> Pp.std_ppcmds
 
+val kn_ord : kernel_name -> kernel_name -> int
 
 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 *)
+(** {6 Specific paths for declarations } *)
 
-type variable = identifier
 type constant
 type mutual_inductive
-(* Beware: first inductive has index 0 *)
+
+(** Beware: first inductive has index 0 *)
 type inductive = mutual_inductive * int
-(* Beware: first constructor has index 1 *)
+
+(** Beware: first constructor has index 1 *)
 type constructor = inductive * int
 
-(* *_env modules consider an order on user part of names
+(** *_env modules consider an order on user part of names
    the others consider an order on canonical part of names*)
 module Cmap  : Map.S with type key = constant
 module Cmap_env  : Map.S with type key = constant
@@ -169,7 +180,6 @@ val debug_string_of_mind : mutual_inductive -> string
 
 
 
-val mind_modpath : mutual_inductive -> module_path
 val ind_modpath : inductive -> module_path
 val constr_modpath : constructor -> module_path
 
@@ -180,7 +190,7 @@ val index_of_constructor : constructor -> int
 val eq_ind : inductive -> inductive -> bool
 val eq_constructor : constructor -> constructor -> bool
 
-(* Better to have it here that in Closure, since required in grammar.cma *)
+(** Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
   | EvalConstRef of constant
@@ -188,12 +198,16 @@ type evaluable_global_reference =
 val eq_egr : evaluable_global_reference ->  evaluable_global_reference
   -> bool
 
-(* Hash-consing *)
-val hcons_names : unit ->
-  (constant -> constant) *
-  (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) *
-  (name -> name) * (identifier -> identifier) * (string -> string)
+(** {6 Hash-consing } *)
 
+val hcons_string : string -> string
+val hcons_ident : identifier -> identifier
+val hcons_name : name -> name
+val hcons_dirpath : dir_path -> dir_path
+val hcons_con : constant -> constant
+val hcons_mind : mutual_inductive -> mutual_inductive
+val hcons_ind : inductive -> inductive
+val hcons_construct : constructor -> constructor
 
 (******)
 
@@ -209,8 +223,8 @@ val full_transparent_state : transparent_state
 val var_full_transparent_state : transparent_state
 val cst_full_transparent_state : transparent_state
 
-type inv_rel_key = int (* index in the [rel_context] part of environment
-			  starting by the end, {\em inverse}
+type inv_rel_key = int (** index in the [rel_context] part of environment
+			  starting by the end, {e inverse}
 			  of de Bruijn indice *)
 
 type id_key = inv_rel_key tableKey
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index c852ab72..985aac95 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Benjamin Grégoire out of environ.ml for better
+   modularity in the design of the bytecode virtual evaluation
+   machine, Dec 2005 *)
+(* Bug fix by Jean-Marc Notin *)
+
+(* This file defines the type of kernel environments *)
 
 open Util
 open Names
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 70776551..40ce887b 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Sign
@@ -15,7 +13,7 @@ open Univ
 open Term
 open Declarations
 
-(* The type of environments. *)
+(** The type of environments. *)
 
 
 type key = int option ref
@@ -57,25 +55,27 @@ val empty_named_context_val : named_context_val
 
 val empty_env : env
 
-(* Rel context *)
+(** Rel context *)
 
 val nb_rel         : env -> int
 val push_rel       : rel_declaration -> env -> env
 val lookup_rel_val : int -> env -> lazy_val
 val env_of_rel     : int -> env -> env
-(* Named context *)
+
+(** Named context *)
 
 val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 val push_named       : named_declaration -> env -> env
 val lookup_named_val : identifier -> env -> lazy_val
 val env_of_named     : identifier -> env -> env
-(* Global constants *)
+
+(** Global constants *)
 
 
 val lookup_constant_key : constant -> env -> constant_key
 val lookup_constant : constant -> env -> constant_body
 
-(* Mutual Inductives *)
+(** Mutual Inductives *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 38d1c70b..fc5e32cf 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -1,12 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created under Benjamin Werner account by Bruno Barras to implement
+   a call-by-value conversion algorithm and a lazy reduction machine
+   with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Irreversibility of opacity by Bruno Barras *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Equal inductive types by Jacek Chrzaszcz as part of the module
+   system, Aug 2002 *)
 
 open Util
 open Names
@@ -190,9 +197,9 @@ let sort_cmp pb s0 s1 cuniv =
     | (_, _) -> raise NotConvertible
 
 
-let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
+let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint
 
-let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
+let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint
 
 let rec no_arg_available = function
   | [] -> true
@@ -232,14 +239,14 @@ let in_whnf (t,stk) =
     | FLOCKED -> assert false
 
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
-let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv =
-  eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
+let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv =
+  eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
-and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
+and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
   Util.check_for_interrupt ();
   (* First head reduce both terms *)
-  let rec  whd_both (t1,stk1) (t2,stk2) =
+  let rec whd_both (t1,stk1) (t2,stk2) =
     let st1' = whd_stack (snd infos) t1 stk1 in
     let st2' = whd_stack (snd infos) t2 stk2 in
     (* Now, whd_stack on term2 might have modified st1 (due to sharing),
@@ -260,13 +267,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
 	       sort_cmp cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
                if n=m
-	       then convert_stacks infos lft1 lft2 v1 v2 cuniv
+	       then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
                else raise NotConvertible
 	   | _ -> raise NotConvertible)
     | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) ->
         if ev1=ev2 then
-          let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in
-          convert_vect infos el1 el2
+          let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
+          convert_vect l2r infos el1 el2
             (Array.map (mk_clos env1) args1)
             (Array.map (mk_clos env2) args2) u1
         else raise NotConvertible
@@ -274,19 +281,19 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* 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
+        then convert_stacks l2r 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 eq_table_key fl1 fl2
-          then convert_stacks infos lft1 lft2 v1 v2 cuniv
+          then convert_stacks l2r 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
+            if Conv_oracle.oracle_order l2r fl1 fl2 then
               match unfold_reference infos fl1 with
                 | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
                 | None ->
@@ -300,79 +307,95 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
                     (match unfold_reference infos fl1 with
                     | Some def1 -> ((lft1, whd_stack (snd 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 (snd 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 (snd infos) def2 v2) cuniv
-           | None -> raise NotConvertible)
+          eqappr cv_pb l2r infos app1 app2 cuniv)
 
     (* other constructors *)
     | (FLambda _, FLambda _) ->
+        (* Inconsistency: we tolerate that v1, v2 contain shift and update but
+           we throw them away *)
         if not (is_empty_stack v1 && is_empty_stack v2) then
 	  anomaly "conversion was given ill-typed terms (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
+        let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1
 
     | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
         if not (is_empty_stack v1 && is_empty_stack v2) then
 	  anomaly "conversion was given ill-typed terms (FProd)";
 	(* 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
+        let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1
+
+    (* Eta-expansion on the fly *)
+    | (FLambda _, _) ->
+        if v1 <> [] then
+	  anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
+	eqappr CONV l2r infos
+	  (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv
+    | (_, FLambda _) ->
+        if v2 <> [] then
+	  anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
+	eqappr CONV l2r infos
+	  (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 ->
+	       eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 ->
+	       eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
+           | None -> raise NotConvertible)
 
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
-     | (FInd ind1, FInd ind2) ->
-         if eq_ind ind1 ind2
-	 then
-           convert_stacks infos lft1 lft2 v1 v2 cuniv
-         else raise NotConvertible
-
-     | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
-	 if j1 = j2 && eq_ind ind1 ind2
-	 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
+    | (FInd ind1, FInd ind2) ->
+        if eq_ind ind1 ind2
+	then
+          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+        else raise NotConvertible
+
+    | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
+	if j1 = j2 && eq_ind ind1 ind2
+	then
+          convert_stacks l2r 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 l2r infos el1 el2 fty1 fty2 cuniv in
+          let u2 =
+            convert_vect l2r infos
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+          convert_stacks l2r 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 l2r infos el1 el2 fty1 fty2 cuniv in
+          let u2 =
+	    convert_vect l2r infos
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+        else raise NotConvertible
 
      (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
      | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
@@ -382,13 +405,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
      (* In all other cases, terms are not convertible *)
      | _ -> raise NotConvertible
 
-and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
+and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
-    (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
+    (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c)
     (eq_ind)
     lft1 stk1 lft2 stk2 cuniv
 
-and convert_vect infos lft1 lft2 v1 v2 cuniv =
+and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
   let lv1 = Array.length v1 in
   let lv2 = Array.length v2 in
   if lv1 = lv2
@@ -396,62 +419,62 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv =
     let rec fold n univ =
       if n >= lv1 then univ
       else
-        let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
+        let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in
         fold (n+1) u1 in
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv trans cv_pb evars env t1 t2 =
+let clos_fconv trans cv_pb l2r evars env t1 t2 =
   let infos = trans, create_clos_infos ~evars betaiotazeta env in
-  ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
+  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint
 
-let trans_fconv reds cv_pb evars env t1 t2 =
-  if eq_constr t1 t2 then Constraint.empty
-  else clos_fconv reds cv_pb evars env t1 t2
+let trans_fconv reds cv_pb l2r evars env t1 t2 =
+  if eq_constr t1 t2 then empty_constraint
+  else clos_fconv reds cv_pb l2r evars env t1 t2
 
-let trans_conv_cmp conv reds = trans_fconv reds conv (fun _->None)
-let trans_conv ?(evars=fun _->None) reds = trans_fconv reds CONV evars
-let trans_conv_leq ?(evars=fun _->None) reds = trans_fconv reds CUMUL evars
+let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None)
+let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars
+let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars
 
 let fconv = trans_fconv (Idpred.full, Cpred.full)
 
-let conv_cmp cv_pb = fconv cv_pb (fun _->None)
-let conv ?(evars=fun _->None) = fconv CONV evars
-let conv_leq ?(evars=fun _->None) = fconv CUMUL evars
+let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None)
+let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars
+let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars
 
-let conv_leq_vecti ?(evars=fun _->None) env v1 v2 =
+let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
   array_fold_left2_i
     (fun i c t1 t2 ->
       let c' =
-        try conv_leq ~evars env t1 t2
+        try conv_leq ~l2r ~evars env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
-      Constraint.union c c')
-    Constraint.empty
+      union_constraints c c')
+    empty_constraint
     v1
     v2
 
 (* option for conversion *)
 
-let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
 let set_vm_conv f = vm_conv := f
 let vm_conv cv_pb env t1 t2 =
   try
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
-      fconv cv_pb (fun _->None) env t1 t2
+      fconv cv_pb false (fun _->None) env t1 t2
 
 
-let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None))
 
 let set_default_conv f = default_conv := f
 
-let default_conv cv_pb env t1 t2 =
+let default_conv cv_pb ?(l2r=false) env t1 t2 =
   try
-    !default_conv cv_pb env t1 t2
+    !default_conv ~l2r cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
-      fconv cv_pb (fun _->None) env t1 t2
+      fconv cv_pb false (fun _->None) env t1 t2
 
 let default_conv_leq = default_conv CUMUL
 (*
@@ -511,15 +534,16 @@ let dest_prod_assum env =
   in
   prodec_rec env empty_rel_context
 
+exception NotArity
+
 let dest_arity env c =
   let l, c = dest_prod_assum env c in
   match kind_of_term c with
     | Sort s -> l,s
-    | _ -> error "not an arity"
+    | _ -> raise NotArity
 
 let is_arity env c =
   try
     let _ = dest_arity env c in
     true
-  with UserError _ -> false
-
+  with NotArity -> false
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 4a3e4cd5..aa78fbda 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Environ
 open Closure
-(*i*)
 
-(************************************************************************)
-(*s Reduction functions *)
+(***********************************************************************
+  s Reduction functions *)
 
 val whd_betaiotazeta        : constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
@@ -24,8 +20,8 @@ val whd_betadeltaiota_nolet : env -> constr -> constr
 val whd_betaiota      : constr -> constr
 val nf_betaiota      : constr -> constr
 
-(************************************************************************)
-(*s conversion functions *)
+(***********************************************************************
+  s conversion functions *)
 
 exception NotConvertible
 exception NotConvertibleVect of int
@@ -40,45 +36,47 @@ val sort_cmp :
 val conv_sort      : sorts conversion_function
 val conv_sort_leq  : sorts conversion_function
 
-val trans_conv_cmp       : conv_pb -> constr trans_conversion_function
+val trans_conv_cmp       : ?l2r:bool -> conv_pb -> constr trans_conversion_function
 val trans_conv           :
-  ?evars:(existential->constr option) -> constr trans_conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function
 val trans_conv_leq       :
-  ?evars:(existential->constr option) -> types trans_conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
 
-val conv_cmp       : conv_pb -> constr conversion_function
+val conv_cmp       : ?l2r:bool -> conv_pb -> constr conversion_function
 val conv           :
-  ?evars:(existential->constr option) -> constr conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
 val conv_leq       :
-  ?evars:(existential->constr option) -> types conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function
 val conv_leq_vecti :
-  ?evars:(existential->constr option) -> types array conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
 
-(* option for conversion *)
+(** option for conversion *)
 val set_vm_conv : (conv_pb -> types conversion_function) -> unit
 val vm_conv : conv_pb -> types conversion_function
 
-val set_default_conv : (conv_pb -> types conversion_function) -> unit
-val default_conv     : conv_pb -> types conversion_function
-val default_conv_leq : types conversion_function
+val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit
+val default_conv     : conv_pb -> ?l2r:bool -> types conversion_function
+val default_conv_leq : ?l2r:bool -> types conversion_function
 
 (************************************************************************)
 
-(* Builds an application node, reducing beta redexes it may produce. *)
+(** Builds an application node, reducing beta redexes it may produce. *)
 val beta_appvect : constr -> constr array -> constr
 
-(* Builds an application node, reducing the [n] first beta-zeta redexes. *)
+(** Builds an application node, reducing the [n] first beta-zeta redexes. *)
 val betazeta_appvect : int -> constr -> constr array -> constr
 
-(* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
+(** 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 *)
+(***********************************************************************
+  s Recognizing products and arities modulo reduction *)
 
 val dest_prod       : env -> types -> rel_context * types
 val dest_prod_assum : env -> types -> rel_context * types
 
-val dest_arity : env -> types -> arity
+exception NotArity
+
+val dest_arity : env -> types -> arity (* raises NotArity if not an arity *)
 val is_arity   : env -> types -> bool
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index 5e8dd9f8..10d0bae7 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retroknowledge.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Arnaud Spiwack, May 2007 *)
+(* Addition of native Head (nb of heading 0) and Tail (nb of trailing 0) by
+   Benjamin Grégoire, Jun 2007 *)
+
+(* This file defines the knowledge that the kernel is able to optimize
+   for evaluation in the bytecode virtual machine *)
 
 open Term
 open Names
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 6cf871d3..b9793f6d 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retroknowledge.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
-(*i*)
 
 type retroknowledge
 
-(* aliased type for clarity purpose*)
+(** aliased type for clarity purpose*)
 type entry =  (constr, types) kind_of_term
 
-(* the following types correspond to the different "things"
+(** the following types correspond to the different "things"
    the kernel can learn about.*)
 type nat_field =
   | NatType
@@ -58,25 +54,26 @@ type int31_field =
   | Int31Tail0
 
 type field =
-(*  | KEq
+
+(**  | KEq
   | KNat of nat_field
   | KN of n_field *)
   | KInt31 of string*int31_field
 
 
-(* This type represent an atomic action of the retroknowledge. It
-   is stored in the compiled libraries *)
-(* As per now, there is only the possibility of registering things
+(** This type represent an atomic action of the retroknowledge. It
+   is stored in the compiled libraries 
+   As per now, there is only the possibility of registering things
    the possibility of unregistering or changing the flag is under study *)
 type action =
     | RKRegister of field*entry
 
 
-(* initial value for retroknowledge *)
+(** initial value for retroknowledge *)
 val initial_retroknowledge : retroknowledge
 
 
-(* Given an identifier id (usually Const _)
+(** Given an identifier id (usually Const _)
    and the continuation cont of the bytecode compilation
    returns the compilation of id in cont if it has a specific treatment
    or raises Not_found if id should be compiled as usual *)
@@ -103,28 +100,29 @@ val get_vm_constant_dynamic_info : retroknowledge -> entry ->
                                 Cbytecodes.comp_env ->
                                 Cbytecodes.block array ->
                                 int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes
-(* Given a type identifier, this function is used before compiling a match
+
+(** Given a type identifier, this function is used before compiling a match
    over this type. In the case of 31-bit integers for instance, it is used
    to add the instruction sequence which would perform a dynamic decompilation
    in case the argument of the match is not in coq representation *)
 val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes
                                                        -> Cbytecodes.bytecodes
 
-(* Given a type identifier, this function is used by pretyping/vnorm.ml to
+(** Given a type identifier, this function is used by pretyping/vnorm.ml to
    recover the elements of that type from their compiled form if it's non
    standard (it is used (and can be used) only when the compiled form
    is not a block *)
 val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr
 
 
-(* the following functions are solely used in Pre_env and Environ to implement
+(** the following functions are solely used in Pre_env and Environ to implement
    the functions  register and unregister (and mem) of Environ *)
 val add_field : retroknowledge -> field -> entry -> retroknowledge
 val mem : retroknowledge -> field -> bool
 val remove : retroknowledge -> field -> retroknowledge
 val find : retroknowledge -> field -> entry
 
-(* the following function manipulate the reactive information of values
+(** the following function manipulate the reactive information of values
    they are only used by the functions of Pre_env, and Environ to implement
    the functions register and unregister of Environ *)
 val add_vm_compiling_info : retroknowledge-> entry ->
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 4575d5bc..c2d71ebb 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -1,12 +1,61 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre as part of the rebuilding of
+   Coq around a purely functional abstract type-checker, Dec 1999 *)
+
+(* This file provides the entry points to the kernel type-checker. It
+   defines the abstract type of well-formed environments and
+   implements the rules that build well-formed environments.
+
+   An environment is made of constants and inductive types (E), of
+   section declarations (Delta), of local bound-by-index declarations
+   (Gamma) and of universe constraints (C). Below E[Delta,Gamma] |-_C
+   means that the tuple E, Delta, Gamma, C is a well-formed
+   environment. Main rules are:
+
+   empty_environment:
+
+     ------
+     [,] |-
+
+   push_named_assum(a,T):
+   
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E[Delta,Gamma,a:T] |-_G'
+
+   push_named_def(a,t,T):
+   
+     E[Delta,Gamma] |-_G
+     ---------------------------
+     E[Delta,Gamma,a:=t:T] |-_G'
+
+   add_constant(ConstantEntry(DefinitionEntry(c,t,T))):
+
+     E[Delta,Gamma] |-_G
+     ---------------------------
+     E,c:=t:T[Delta,Gamma] |-_G'
+
+   add_constant(ConstantEntry(ParameterEntry(c,T))):
+
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E,c:T[Delta,Gamma] |-_G'
+
+   add_mind(Ind(Ind[Gamma_p](Gamma_I:=Gamma_C))):
+
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E,Ind[Gamma_p](Gamma_I:=Gamma_C)[Delta,Gamma] |-_G'
+
+   etc.
+*)
 
 open Util
 open Names
@@ -41,25 +90,6 @@ type module_info =
      resolver : delta_resolver;
      resolver_of_param : delta_resolver;}
 
-let check_label l labset =
-  if Labset.mem l labset then error_existing_label l
-
-let check_labels ls senv =
-  Labset.iter (fun l -> check_label l senv) ls
-
-let labels_of_mib mib =
-  let add,get =
-    let labels = ref Labset.empty in
-    (fun id -> labels := Labset.add (label_of_id id) !labels),
-    (fun () -> !labels)
-  in
-  let visit_mip mip =
-    add mip.mind_typename;
-    Array.iter add mip.mind_consnames
-  in
-  Array.iter visit_mip mib.mind_packets;
-  get ()
-
 let set_engagement_opt oeng env =
   match oeng with
       Some eng -> set_engagement eng env
@@ -79,16 +109,26 @@ type safe_environment =
       loads : (module_path * module_body) list;
       local_retroknowledge : Retroknowledge.action list}
 
-(*
-  { old = senv.old;
-    env = ;
-    modinfo = senv.modinfo;
-    labset = ;
-    revsign = ;
-    imports = senv.imports ;
-    loads = senv.loads }
-*)
+let exists_label l senv = Labset.mem l senv.labset
+
+let check_label l senv =
+  if exists_label l senv then error_existing_label l
 
+let check_labels ls senv =
+  Labset.iter (fun l -> check_label l senv) ls
+
+let labels_of_mib mib =
+  let add,get =
+    let labels = ref Labset.empty in
+    (fun id -> labels := Labset.add (label_of_id id) !labels),
+    (fun () -> !labels)
+  in
+  let visit_mip mip =
+    add mip.mind_typename;
+    Array.iter add mip.mind_consnames
+  in
+  Array.iter visit_mip mib.mind_packets;
+  get ()
 
 (* a small hack to avoid variants and an unused case in all functions *)
 let rec empty_environment =
@@ -102,7 +142,7 @@ let rec empty_environment =
       resolver_of_param = empty_delta_resolver};
     labset = Labset.empty;
     revstruct = [];
-    univ = Univ.Constraint.empty;
+    univ = Univ.empty_constraint;
     engagement = None;
     imports = [];
     loads = [];
@@ -111,16 +151,50 @@ let rec empty_environment =
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
 
-
-
-
-
-
-
 let add_constraints cst senv =
-  {senv with
+  { senv with
     env = Environ.add_constraints cst senv.env;
-    univ = Univ.Constraint.union cst senv.univ }
+    univ = Univ.union_constraints cst senv.univ }
+
+let constraints_of_sfb = function
+  | SFBconst cb -> cb.const_constraints
+  | SFBmind mib -> mib.mind_constraints
+  | SFBmodtype mtb -> mtb.typ_constraints
+  | SFBmodule mb -> mb.mod_constraints
+
+(* A generic function for adding a new field in a same environment.
+   It also performs the corresponding [add_constraints]. *)
+
+type generic_name =
+  | C of constant
+  | I of mutual_inductive
+  | MT of module_path
+  | M
+
+let add_field ((l,sfb) as field) gn senv =
+  let labels = match sfb with
+    | SFBmind mib -> labels_of_mib mib
+    | _ -> Labset.singleton l
+  in
+  check_labels labels senv;
+  let senv = add_constraints (constraints_of_sfb sfb) senv in
+  let env' = match sfb, gn with
+    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+    | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
+    | SFBmodule mb, M -> Modops.add_module mb senv.env
+    | _ -> assert false
+  in
+  { senv with
+    env = env';
+    labset = Labset.union labels senv.labset;
+    revstruct = field :: senv.revstruct }
+
+(* Applying a certain function to the resolver of a safe environment *)
+
+let update_resolver f senv =
+  let mi = senv.modinfo in
+  { senv with modinfo = { mi with resolver = f mi.resolver }}
 
 
 (* universal lifting, used for the "get" operations mostly *)
@@ -131,8 +205,9 @@ let register senv field value by_clause =
   (* todo : value closed, by_clause safe, by_clause of the proper type*)
   (* spiwack : updates the safe_env with the information that the register
      action has to be performed (again) when the environement is imported *)
-  {senv with env = Environ.register senv.env field value;
-             local_retroknowledge =
+  {senv with
+    env = Environ.register senv.env field value;
+    local_retroknowledge =
       Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
   }
 
@@ -185,52 +260,21 @@ type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
 
-let hcons_constant_type = function
-  | NonPolymorphicType t ->
-      NonPolymorphicType (hcons1_constr t)
-  | PolymorphicArity (ctx,s) ->
-      PolymorphicArity (map_rel_context hcons1_constr ctx,s)
-
-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 = hcons_constant_type cb.const_type }
-
 let add_constant dir l decl senv =
-  check_label l senv.labset;
   let kn = make_con senv.modinfo.modpath dir l in
-  let cb =
-    match decl with
-      | ConstantEntry ce -> translate_constant senv.env kn ce
-      | GlobalRecipe r ->
-	  let cb = translate_recipe senv.env kn r in
-	    if dir = empty_dirpath then hcons_constant_body cb else cb
+  let cb = match decl with
+    | ConstantEntry ce -> translate_constant senv.env kn ce
+    | GlobalRecipe r ->
+      let cb = translate_recipe senv.env kn r in
+      if dir = empty_dirpath then hcons_const_body cb else cb
   in
-  let senv' = add_constraints cb.const_constraints senv in
-  let env'' = Environ.add_constant kn cb senv'.env in
-  let resolver = 
-    if cb.const_inline then
-      add_inline_delta_resolver kn senv'.modinfo.resolver
-    else
-      senv'.modinfo.resolver
+  let senv' = add_field (l,SFBconst cb) (C kn) senv in
+  let senv'' = match cb.const_body with
+    | Undef (Some lev) ->
+      update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv'
+    | _ -> senv'
   in
-    kn, { old = senv'.old;
-	  env = env'';
-	  modinfo = {senv'.modinfo with
-		       resolver = resolver};
-	  labset = Labset.add l senv'.labset;
-	  revstruct = (l,SFBconst cb)::senv'.revstruct;
-          univ = senv'.univ;
-          engagement = senv'.engagement;
-	  imports = senv'.imports;
-	  loads = senv'.loads ;
-	  local_retroknowledge = senv'.local_retroknowledge }
-
+  kn, senv''
 
 (* Insertion of inductive types. *)
 
@@ -242,79 +286,41 @@ let add_mind dir l mie senv =
   if l <> label_of_id id then
     anomaly ("the label of inductive packet and its first inductive"^
 	     " type do not match");
-  let mib = translate_mind senv.env mie in
-  let labels = labels_of_mib mib in
-  check_labels labels senv.labset;
-  let senv' = add_constraints mib.mind_constraints senv in
   let kn = make_mind senv.modinfo.modpath dir l in
-  let env'' = Environ.add_mind kn mib senv'.env in
-  kn, { old = senv'.old;
-	env = env'';
-	modinfo = senv'.modinfo;
-	labset = Labset.union labels senv'.labset;
-	revstruct = (l,SFBmind mib)::senv'.revstruct;
-        univ = senv'.univ;
-        engagement = senv'.engagement;
-	imports = senv'.imports;
-	loads = senv'.loads;
-        local_retroknowledge = senv'.local_retroknowledge }
+  let mib = translate_mind senv.env kn mie in
+  let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in
+  let senv' = add_field (l,SFBmind mib) (I kn) senv in
+  kn, senv'
 
 (* Insertion of module types *)
 
 let add_modtype l mte inl senv =
-  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
   let mtb = translate_module_type senv.env mp inl mte  in
-  let senv' = add_constraints mtb.typ_constraints senv in
-   let env'' = Environ.add_modtype mp mtb senv'.env in
-    mp, { old = senv'.old;
-	  env = env'';
-	  modinfo = senv'.modinfo;
-	  labset = Labset.add l senv'.labset;
-	  revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
-          univ = senv'.univ;
-          engagement = senv'.engagement;
-	  imports = senv'.imports;
-	  loads = senv'.loads;
-          local_retroknowledge = senv'.local_retroknowledge }
-
+  let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in
+  mp, senv'
 
 (* full_add_module adds module with universes and constraints *)
 let full_add_module mb senv =
   let senv = add_constraints mb.mod_constraints senv in
-  let env = Modops.add_module mb senv.env in
-    {senv with env = env}
+  { senv with env = Modops.add_module mb senv.env }
 
 (* Insertion of modules *)
 
 let add_module l me inl senv =
-  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
   let mb = translate_module senv.env mp inl me in
-  let senv' = full_add_module mb senv  in
-  let modinfo = match mb.mod_type with
-      SEBstruct _ -> 
-	{ senv'.modinfo with
-	    resolver = 
-	    add_delta_resolver mb.mod_delta senv'.modinfo.resolver}
-    | _ -> senv'.modinfo
+  let senv' = add_field (l,SFBmodule mb) M senv in
+  let senv'' = match mb.mod_type with
+    | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv'
+    | _ -> senv'
   in
-    mp,mb.mod_delta,
-  { old = senv'.old;
-    env = senv'.env;
-    modinfo = modinfo;
-    labset = Labset.add l senv'.labset;
-    revstruct = (l,SFBmodule mb)::senv'.revstruct;
-    univ = senv'.univ;
-    engagement = senv'.engagement;
-    imports = senv'.imports;
-    loads = senv'.loads;
-    local_retroknowledge = senv'.local_retroknowledge }
-    
+  mp,mb.mod_delta,senv''
+
 (* Interactive modules *)
 
 let start_module l senv =
-  check_label l senv.labset;
+  check_label l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -327,7 +333,7 @@ let start_module l senv =
 	 modinfo = modinfo;
 	 labset = Labset.empty;
 	 revstruct = [];
-         univ = Univ.Constraint.empty;
+         univ = Univ.empty_constraint;
          engagement = None;
 	 imports = senv.imports;
 	 loads = [];
@@ -347,7 +353,7 @@ let end_module l restype senv =
       | STRUCT params -> params, (List.length params > 0)
   in
   if l <> modinfo.label then error_incompatible_labels l modinfo.label;
-  if not (empty_context senv.env) then error_local_context None;
+  if not (empty_context senv.env) then error_non_empty_local_context None;
   let functorize_struct tb =
     List.fold_left
       (fun mtb (arg_id,arg_b) ->
@@ -361,13 +367,13 @@ let end_module l restype senv =
    let mexpr,mod_typ,mod_typ_alg,resolver,cst = 
     match restype with
       | None ->  let mexpr = functorize_struct auto_tb in
-	 mexpr,mexpr,None,modinfo.resolver,Constraint.empty
+	 mexpr,mexpr,None,modinfo.resolver,empty_constraint
       | Some mtb ->
 	  let auto_mtb = {
 	    typ_mp = senv.modinfo.modpath;
 	    typ_expr = auto_tb;
 	    typ_expr_alg = None;
-	    typ_constraints = Constraint.empty;
+	    typ_constraints = empty_constraint;
 	    typ_delta = empty_delta_resolver} in
 	  let cst = check_subtypes senv.env auto_mtb
 	    mtb in
@@ -377,7 +383,7 @@ let end_module l restype senv =
 	    Option.map functorize_struct mtb.typ_expr_alg in
 	    mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
   in
-  let cst = Constraint.union cst senv.univ in
+  let cst = union_constraints cst senv.univ in
   let mb =
     { mod_mp = mp;
       mod_expr = Some mexpr;
@@ -411,12 +417,12 @@ let end_module l restype senv =
 		  modinfo = modinfo;
 		  labset = Labset.add l oldsenv.labset;
 		  revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
-		  univ = Univ.Constraint.union senv'.univ oldsenv.univ;
+		  univ = Univ.union_constraints senv'.univ oldsenv.univ;
 		  (* engagement is propagated to the upper level *)
 		  engagement = senv'.engagement;
 		  imports = senv'.imports;
 		  loads = senv'.loads@oldsenv.loads;
-		  local_retroknowledge = 
+		  local_retroknowledge =
 	senv'.local_retroknowledge@oldsenv.local_retroknowledge }
 
 
@@ -424,8 +430,8 @@ let end_module l restype senv =
  let add_include me is_module inl senv =
    let sign,cst,resolver =
      if is_module then
-       let sign,resolver,cst =  
-	 translate_struct_include_module_entry senv.env 
+       let sign,_,resolver,cst =
+	 translate_struct_include_module_entry senv.env
 	   senv.modinfo.modpath inl me in
 	 sign,cst,resolver
      else
@@ -437,106 +443,46 @@ let end_module l restype senv =
    let senv = add_constraints cst senv in
    let mp_sup = senv.modinfo.modpath in
      (* Include Self support  *)
-  let rec compute_sign sign mb resolver senv = 
+   let rec compute_sign sign mb resolver senv = 
      match sign with
      | SEBfunctor(mbid,mtb,str) ->
 	 let cst_sub = check_subtypes senv.env mb mtb in
 	 let senv = add_constraints cst_sub senv in
-	 let mpsup_delta = if not inl then mb.typ_delta else
-	   complete_inline_delta_resolver senv.env mp_sup mbid mtb mb.typ_delta
+	 let mpsup_delta =
+	   inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta
 	 in
 	 let subst = map_mbid mbid mp_sup mpsup_delta in
 	 let resolver = subst_codom_delta_resolver subst resolver in
 	   (compute_sign 
-	      (subst_struct_expr subst str) mb resolver senv)
+	     (subst_struct_expr subst str) mb resolver senv)
      | str -> resolver,str,senv
-  in
+   in
    let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup;
 				      typ_expr = SEBstruct (List.rev senv.revstruct);
 				      typ_expr_alg = None;
-				      typ_constraints = Constraint.empty;
-				      typ_delta = senv.modinfo.resolver} resolver senv in
+				      typ_constraints = empty_constraint;
+				      typ_delta = senv.modinfo.resolver} resolver senv
+   in
    let str = match sign with
      | SEBstruct(str_l) -> str_l
      | _ -> error ("You cannot Include a high-order structure.")
    in
-   let senv =
-     {senv 
-      with modinfo = 
-	 {senv.modinfo
-	  with resolver =
-	     add_delta_resolver resolver senv.modinfo.resolver}}
+   let senv = update_resolver (add_delta_resolver resolver) senv
    in
-   let add senv (l,elem)  =
-     check_label l senv.labset;
-     match elem with
-       | SFBconst cb ->
+   let add senv ((l,elem) as field) =
+     let new_name = match elem with
+       | SFBconst _ ->
 	   let kn = make_kn mp_sup empty_dirpath l in
-	   let con = constant_of_kn_equiv kn
-	     (canonical_con 
-		(constant_of_delta resolver (constant_of_kn kn)))
-	   in
-	   let senv' = add_constraints cb.const_constraints senv in
-	   let env'' = Environ.add_constant con cb senv'.env in
-	     { old = senv'.old;
-	       env = env'';
-	       modinfo = senv'.modinfo;
-	       labset = Labset.add l senv'.labset;
-	       revstruct = (l,SFBconst cb)::senv'.revstruct;
-               univ = senv'.univ;
-               engagement = senv'.engagement;
-	       imports = senv'.imports;
-	       loads = senv'.loads ;
-	       local_retroknowledge = senv'.local_retroknowledge }
-       | SFBmind mib ->
+	   C (constant_of_delta_kn resolver kn)
+       | SFBmind _ ->
 	   let kn = make_kn mp_sup empty_dirpath l in
-	   let mind = mind_of_kn_equiv kn
-	     (canonical_mind 
-		(mind_of_delta resolver (mind_of_kn kn)))
-	   in
-	   let labels = labels_of_mib mib in
-	   check_labels labels senv.labset;
-	   let senv' = add_constraints mib.mind_constraints senv in
-	   let env'' = Environ.add_mind mind mib senv'.env in
-	     { old = senv'.old;
-	       env = env'';
-	       modinfo = senv'.modinfo;
-	       labset = Labset.union labels senv'.labset;
-	       revstruct = (l,SFBmind mib)::senv'.revstruct;
-               univ = senv'.univ;
-               engagement = senv'.engagement;
-	       imports = senv'.imports;
-	       loads = senv'.loads;
-               local_retroknowledge = senv'.local_retroknowledge }
-
-       | SFBmodule mb ->
-	   let senv' = full_add_module mb senv in
-	     { old = senv'.old;
-	       env = senv'.env;
-	       modinfo = senv'.modinfo;
-	       labset = Labset.add l senv'.labset;
-	       revstruct = (l,SFBmodule mb)::senv'.revstruct;
-	       univ = senv'.univ;
-	       engagement = senv'.engagement;
-	       imports = senv'.imports;
-	       loads = senv'.loads;
-	       local_retroknowledge = senv'.local_retroknowledge }
-       | SFBmodtype mtb ->
-	   let senv' = add_constraints mtb.typ_constraints senv in
-	   let mp = MPdot(senv.modinfo.modpath, l) in
-	   let env' = Environ.add_modtype mp mtb senv'.env in
-	     { old = senv.old;
-	       env = env';
-	       modinfo = senv'.modinfo;
-	       labset = Labset.add l senv.labset;
-	       revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
-               univ = senv'.univ;
-               engagement = senv'.engagement;
-	       imports = senv'.imports;
-	       loads = senv'.loads;
-               local_retroknowledge = senv'.local_retroknowledge }
+	   I (mind_of_delta_kn resolver kn)
+       | SFBmodule _ -> M
+       | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l))
+     in
+     add_field field new_name senv
    in
-     resolver,(List.fold_left add senv str)
+   resolver,(List.fold_left add senv str)
 
 (* Adding parameters to modules or module types *)
 
@@ -576,7 +522,7 @@ let add_module_parameter mbid mte inl senv =
 (* Interactive module types *)
 
 let start_modtype l senv =
-  check_label l senv.labset;
+  check_label l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -589,7 +535,7 @@ let start_modtype l senv =
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [] ;
@@ -605,7 +551,7 @@ let end_modtype l senv =
       | 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;
+  if not (empty_context senv.env) then error_non_empty_local_context None;
   let auto_tb =
      SEBstruct (List.rev senv.revstruct)
   in
@@ -640,7 +586,7 @@ let end_modtype l senv =
 	  modinfo = oldsenv.modinfo;
 	  labset = Labset.add l oldsenv.labset;
 	  revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
-          univ = Univ.Constraint.union senv.univ oldsenv.univ;
+          univ = Univ.union_constraints senv.univ oldsenv.univ;
           engagement = senv.engagement;
 	  imports = senv.imports;
 	  loads = senv.loads@oldsenv.loads;
@@ -699,7 +645,7 @@ let start_library dir senv =
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [];
@@ -710,7 +656,7 @@ let pack_module senv =
    mod_expr=None;
    mod_type= SEBstruct (List.rev senv.revstruct);
    mod_type_alg=None;
-   mod_constraints=Constraint.empty;
+   mod_constraints=empty_constraint;
    mod_delta=senv.modinfo.resolver;
    mod_retroknowledge=[];
   }
@@ -786,40 +732,146 @@ let import (dp,mb,depends,engmt) digest senv =
 	  loads = (mp,mb)::senv.loads }
 
 
-(* Remove the body of opaque constants in modules *)
- let rec lighten_module mb =
-  { mb with
-    mod_expr = None;
-    mod_type = lighten_modexpr mb.mod_type;
-  }
-
-and lighten_struct struc =
-  let lighten_body (l,body) = (l,match body with
-    | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
-    | (SFBconst _ | SFBmind _ ) as x -> x
-    | SFBmodule m -> SFBmodule (lighten_module m)
-    | SFBmodtype m -> SFBmodtype
-	({m with
-	    typ_expr = lighten_modexpr m.typ_expr}))
-  in
-    List.map lighten_body struc
-
-and lighten_modexpr = function
-  | SEBfunctor (mbid,mty,mexpr) ->
-      SEBfunctor (mbid,
+ (* Store the body of modules' opaque constants inside a table.  
+
+    This module is used during the serialization and deserialization
+    of vo files. 
+
+    By adding an indirection to the opaque constant definitions, we
+    gain the ability not to load them. As these constant definitions
+    are usually big terms, we save a deserialization time as well as
+    some memory space. *)
+module LightenLibrary : sig
+  type table 
+  type lightened_compiled_library 
+  val save : compiled_library -> lightened_compiled_library * table
+  val load : load_proof:Flags.load_proofs -> table Lazy.t
+    -> lightened_compiled_library -> compiled_library
+end = struct
+
+  (* The table is implemented as an array of [constr_substituted].
+     Keys are hence integers. To avoid changing the [compiled_library]
+     type, we brutally encode integers into [lazy_constr]. This isn't
+     pretty, but shouldn't be dangerous since the produced structure
+     [lightened_compiled_library] is abstract and only meant for writing
+     to .vo via Marshal (which doesn't care about types).
+  *)
+  type table = constr_substituted array
+  let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr)
+  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
+
+  (* To avoid any future misuse of the lightened library that could 
+     interpret encoded keys as real [constr_substituted], we hide 
+     these kind of values behind an abstract datatype. *)
+  type lightened_compiled_library = compiled_library
+
+  (* Map a [compiled_library] to another one by just updating 
+     the opaque term [t] to [on_opaque_const_body t]. *)
+  let traverse_library on_opaque_const_body =
+    let rec traverse_module mb =
+      match mb.mod_expr with 
+	  None -> 
+	    { mb with
+		mod_expr = None;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }
+	| Some impl when impl == mb.mod_type-> 
+	    let mtb =  traverse_modexpr mb.mod_type in 
+	      { mb with
+		  mod_expr = Some mtb;
+		  mod_type = mtb;
+	      }    
+	| Some impl -> 
+	    { mb with
+		mod_expr = Option.map traverse_modexpr mb.mod_expr;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }    
+    and traverse_struct struc =
+      let traverse_body (l,body) = (l,match body with
+	| SFBconst cb when is_opaque cb ->
+	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
+	| (SFBconst _ | SFBmind _ ) as x ->
+	  x
+	| SFBmodule m -> 
+	  SFBmodule (traverse_module m)
+	| SFBmodtype m -> 
+	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
+      in
+      List.map traverse_body struc
+	
+    and traverse_modexpr = function
+      | SEBfunctor (mbid,mty,mexpr) ->
+	SEBfunctor (mbid,
 		    ({mty with
-			typ_expr = lighten_modexpr mty.typ_expr}),
-		  lighten_modexpr mexpr)
-  | SEBident mp as x -> x
-  | SEBstruct (struc) ->
-      SEBstruct  (lighten_struct struc)
-  | SEBapply (mexpr,marg,u) ->
-      SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
-  | SEBwith (seb,wdcl) ->
-      SEBwith (lighten_modexpr seb,wdcl)
-
-let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
-
+		      typ_expr = traverse_modexpr mty.typ_expr}),
+		    traverse_modexpr mexpr)
+      | SEBident mp as x -> x
+      | SEBstruct (struc) ->
+	SEBstruct  (traverse_struct struc)
+      | SEBapply (mexpr,marg,u) ->
+	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
+      | SEBwith (seb,wdcl) ->
+	SEBwith (traverse_modexpr seb,wdcl)
+    in
+    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
+
+  (* To disburden a library from opaque definitions, we simply 
+     traverse it and add an indirection between the module body 
+     and its reference to a [const_body]. *)
+  let save library = 
+    let ((insert    : constant_def -> constant_def),
+	 (get_table : unit -> table)) = 
+      (* We use an integer as a key inside the table. *)
+      let counter = ref (-1) in
+
+      (* During the traversal, the table is implemented by a list 
+	 to get constant time insertion. *)
+      let opaque_definitions = ref [] in
+      
+      ((* Insert inside the table. *) 
+	(fun def ->
+	  let opaque_definition = match def with
+	    | OpaqueDef lc -> force_lazy_constr lc
+	    | _ -> assert false
+	  in
+	  incr counter;
+	  opaque_definitions := opaque_definition :: !opaque_definitions;
+	  OpaqueDef (key_as_lazy_constr !counter)),
+
+       (* Get the final table representation. *)
+       (fun () -> Array.of_list (List.rev !opaque_definitions)))
+    in
+    let lightened_library = traverse_library insert library in
+    (lightened_library, get_table ())
+
+  (* Loading is also a traversing that decodes the embedded keys that
+     are inside the [lightened_library]. If the [load_proof] flag is
+     set, we lookup inside the table to graft the
+     [constr_substituted]. Otherwise, we set the [const_body] field
+     to [None]. 
+  *)
+  let load ~load_proof (table : table Lazy.t) lightened_library =
+    let decode_key = function
+      | Undef _ | Def _ -> assert false
+      | OpaqueDef k ->
+	  let k = key_of_lazy_constr k in
+	  let access key =
+	    try (Lazy.force table).(key)
+	    with _ -> error "Error while retrieving an opaque body"
+	  in
+	  match load_proof with
+	    | Flags.Force ->
+	      let lc = Lazy.lazy_from_val (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Lazy ->
+	      let lc = lazy (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Dont ->
+	      Undef None
+    in
+    traverse_library decode_key lightened_library
+
+end
 
 type judgment = unsafe_judgment
 
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 33a6a775..6f46a45b 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -1,22 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Declarations
 open Entries
 open Mod_subst
-(*i*)
 
-(*s Safe environments. Since we are now able to type terms, we can
+(** {6 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.
 
@@ -31,7 +29,7 @@ val env_of_safe_env : safe_environment -> Environ.env
 val empty_environment : safe_environment
 val is_empty : safe_environment -> bool
 
-(* Adding and removing local declarations (Local or Variables) *)
+(** Adding and removing local declarations (Local or Variables) *)
 val push_named_assum :
   identifier * types -> safe_environment ->
     Univ.constraints * safe_environment
@@ -39,7 +37,7 @@ val push_named_def :
   identifier * constr * types option -> safe_environment ->
     Univ.constraints * safe_environment
 
-(* Adding global axioms or definitions *)
+(** Adding global axioms or definitions *)
 type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
@@ -48,39 +46,40 @@ val add_constant :
   dir_path -> label -> global_declaration -> safe_environment ->
       constant * safe_environment
 
-(* Adding an inductive type *)
+(** Adding an inductive type *)
 val add_mind :
   dir_path -> label -> mutual_inductive_entry -> safe_environment ->
     mutual_inductive * safe_environment
 
-(* Adding a module *)
+(** Adding a module *)
 val add_module :
-  label -> module_entry -> bool -> safe_environment
+  label -> module_entry -> inline -> safe_environment
     -> module_path * delta_resolver * safe_environment
 
-(* Adding a module type *)
+(** Adding a module type *)
 val add_modtype :
-  label -> module_struct_entry -> bool -> safe_environment
+  label -> module_struct_entry -> inline -> safe_environment
     -> module_path * safe_environment
 
-(* Adding universe constraints *)
+(** Adding universe constraints *)
 val add_constraints :
   Univ.constraints -> safe_environment -> safe_environment
 
-(* Settin the strongly constructive or classical logical engagement *)
+(** Settin the strongly constructive or classical logical engagement *)
 val set_engagement : engagement -> safe_environment -> safe_environment
 
 
-(*s Interactive module functions *)
+(** {6 Interactive module functions } *)
+
 val start_module :
   label -> safe_environment -> module_path * safe_environment
 
 val end_module :
-  label -> (module_struct_entry * bool) option
+  label -> (module_struct_entry * inline) option
       -> safe_environment -> module_path * delta_resolver * safe_environment 
 
 val add_module_parameter :
-  mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment
+  mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment
 
 val start_modtype :
   label -> safe_environment -> module_path * safe_environment
@@ -89,16 +88,17 @@ val end_modtype :
   label -> safe_environment -> module_path * safe_environment
 
 val add_include :
-  module_struct_entry -> bool -> bool -> safe_environment ->
+  module_struct_entry -> bool -> inline -> safe_environment ->
    delta_resolver * safe_environment
 
 val pack_module : safe_environment -> module_body
 val current_modpath : safe_environment -> module_path
 val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
   
-(* Loading and saving compilation units *)
 
-(* exporting and importing modules *)
+(** Loading and saving compilation units *)
+
+(** exporting and importing modules *)
 type compiled_library
 
 val start_library : dir_path -> safe_environment
@@ -110,18 +110,25 @@ val export : safe_environment -> dir_path
 val import : compiled_library -> Digest.t -> safe_environment
       -> module_path * safe_environment
 
-(* Remove the body of opaque constants *)
+(** Remove the body of opaque constants *)
 
-val lighten_library : compiled_library -> compiled_library
+module LightenLibrary :
+sig
+  type table
+  type lightened_compiled_library
+  val save : compiled_library -> lightened_compiled_library * table
+  val load : load_proof:Flags.load_proofs -> table Lazy.t ->
+    lightened_compiled_library -> compiled_library
+end
 
-(*s Typing judgments *)
+(** {6 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
+(** 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
  *)
@@ -129,7 +136,9 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
 
 val typing : safe_environment -> constr -> judgment
 
+(** {7 Query } *)
 
+val exists_label : label -> safe_environment -> bool
 
 (*spiwack: safe retroknowledge functionalities *)
 
diff --git a/kernel/sign.ml b/kernel/sign.ml
index d241f677..71169563 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -1,12 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
+   rebuilding of Coq around a purely functional abstract type-checker,
+   Aug 1999 *)
+(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
+   Herbelin and Bruno Barras *)
+
+(* This file defines types and combinators regarding indexes-based and
+   names-based contexts *)
 
 open Names
 open Util
@@ -27,6 +34,7 @@ let rec lookup_named id = function
   | [] -> raise Not_found
 
 let named_context_length = List.length
+let named_context_equal = list_equal eq_named_declaration
 
 let vars_of_named_context = List.map (fun (id,_,_) -> id)
 
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 35e49003..074139c9 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -1,19 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: sign.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
-(*i*)
 
-(*s Signatures of ordered named declarations *)
+(** {6 Signatures of ordered named declarations } *)
 
 type named_context = named_declaration list
 type section_context = named_context
@@ -24,39 +20,45 @@ val vars_of_named_context : named_context -> identifier list
 
 val lookup_named : identifier -> named_context -> named_declaration
 
-(* number of declarations *)
+(** number of declarations *)
 val named_context_length : named_context -> int
 
-(*s Recurrence on [named_context]: older declarations processed first *)
+(** named context equality *)
+val named_context_equal : named_context -> named_context -> bool
+
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
 val fold_named_context :
   (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
 val fold_named_context_reverse :
   ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
 
-(*s Section-related auxiliary functions *)
+(** {6 Section-related auxiliary functions } *)
 val instance_from_named_context : named_context -> constr array
 
-(*s Signatures of ordered optionally named variables, intended to be
+(** {6 ... } *)
+(** Signatures of ordered optionally named variables, intended to be
    accessed by de Bruijn indices *)
 
 val push_named_to_rel_context : named_context -> rel_context -> rel_context
 
-(*s Recurrence on [rel_context]: older declarations processed first *)
+(** {6 Recurrence on [rel_context]: older declarations processed first } *)
 val fold_rel_context :
   (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
 val fold_rel_context_reverse :
   ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
 
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
 val map_rel_context : (constr -> constr) -> rel_context -> rel_context
 
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
 val map_named_context : (constr -> constr) -> named_context -> named_context
 
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
 val iter_rel_context : (constr -> unit) -> rel_context -> unit
 
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
 val iter_named_context : (constr -> unit) -> named_context -> unit
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 447e062a..c141a02a 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -1,12 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module checks subtyping of module types *)
 
 (*i*)
 open Util
@@ -22,8 +25,6 @@ open Mod_subst
 open Entries
 (*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 *)
@@ -66,26 +67,26 @@ let make_label_map mp list =
   in
     List.fold_right add_one list Labmap.empty
 
-let check_conv_error error cst f env a1 a2 =
+let check_conv_error error why cst f env a1 a2 =
   try
-    Constraint.union cst (f env a1 a2)
+    union_constraints cst (f env a1 a2)
   with
-      NotConvertible -> error ()
+      NotConvertible -> error why
 
 (* for now we do not allow reorderings *)
 
 let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= 
   let kn1 = make_mind mp1 empty_dirpath l in
   let kn2 = make_mind mp2 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 error why = error_signature_mismatch l spec2 why in
+  let check_conv why cst f = check_conv_error error why cst f in
   let mib1 =
     match info1 with
       | IndType ((_,0), mib) -> subst_mind subst1 mib
-      | _ -> error ()
+      | _ -> error (InductiveFieldExpected mib2)
   in
   let mib2 =  subst_mind subst2 mib2 in
-  let check_inductive_type cst env t1 t2 =
+  let check_inductive_type cst name env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
        t1 and t2, if in Type, are generated as the least upper bounds
@@ -114,40 +115,43 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     let s1,s2 =
       match s1, s2 with
       | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort
-      | (Prop _, Type _) | (Type _,Prop _) -> error ()
+      | (Prop _, Type _) | (Type _,Prop _) ->
+	error (NotConvertibleInductiveField name)
       | _ -> (s1, s2) in
-    check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+    check_conv (NotConvertibleInductiveField name)
+      cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   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);
+    let check f why = if f p1 <> f p2 then error why in
+      check (fun p -> p.mind_consnames) NotSameConstructorNamesField;
+      check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField;
       (* nf_lc later *)
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      check (fun p -> p.mind_nrealargs);
+      check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
       (* nparams done *)
       (* params_ctxt done because part of the inductive types *)
       (* Don't check the sort of the type if polymorphic *)
-      let cst = check_inductive_type cst env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
+      let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
       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)
+    array_fold_left3
+      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2)
       cst
+      p2.mind_consnames
       (arities_of_specif kn1 (mib1,p1))
       (arities_of_specif kn1 (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);
+  let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in
+  check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x);
+  check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x);
   assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
   assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
@@ -157,17 +161,17 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
   (* at the time of checking the inductive arities in check_packet. *)
   (* Notice that we don't expect the local definitions to match: only *)
   (* the inductive types and constructors types have to be convertible *)
-  check (fun mib -> mib.mind_nparams);
+  check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x);
 
-  begin  
+  begin
   match mind_of_delta reso2 kn2  with
       | kn2' when kn2=kn2' -> ()
       | kn2' -> 
 	  if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then 
-	    error ()
+	    error NotEqualInductiveAliases
   end;
   (* we check that records and their field names are preserved. *)
-  check (fun mib -> mib.mind_record);
+  check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x);
   if mib1.mind_record then begin
     let rec names_prod_letin t = match kind_of_term t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
@@ -179,7 +183,11 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     assert (Array.length mib2.mind_packets = 1);
     assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
     assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
-    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
+    check (fun mib ->
+      let nparamdecls = List.length mib.mind_params_ctxt in
+      let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in
+      snd (list_chop nparamdecls names))
+      (fun x -> RecordProjectionsExpected x);
   end;
   (* we first check simple things *)
   let cst =
@@ -193,7 +201,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
 
     
 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
-  let error () = error_not_match l spec2 in
+  let error why = error_signature_mismatch l spec2 why in
   let check_conv cst f = check_conv_error error cst f in
   let check_type cst env t1 t2 =
 
@@ -233,66 +241,42 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
                  constraints of the form "univ <= max(...)" are not
                  expressible in the system of algebraic universes: we fail
                  (the user has to use an explicit type in the interface *)
-                error ()
-          with UserError _ (* "not an arity" *) ->
-            error () end
-        | _ -> t1,t2
+                error NoTypeConstraintExpected
+          with NotArity ->
+            error NotConvertibleTypeField end
+        | _ ->
+	  t1,t2
       else
         (t1,t2) in
-    check_conv cst conv_leq env t1 t2
+    check_conv NotConvertibleTypeField cst conv_leq env t1 t2
   in
 
   match info1 with
     | Constant cb1 ->
-	assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-	(*Start by checking types*)
-	let cb1 = subst_const_body subst1 cb1 in
-	let cb2 = subst_const_body subst2 cb2 in
+      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+      let cb1 = subst_const_body subst1 cb1 in
+      let cb2 = subst_const_body subst2 cb2 in
+      (* Start by checking types*)
       let typ1 = Typeops.type_of_constant_type env cb1.const_type in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
       let cst = check_type cst env typ1 typ2 in
-      let con = make_con mp1 empty_dirpath l in
-      let cst =
-	if cb2.const_opaque then
-	  (* In this case we compare opaque definitions, we need to bypass
-	     the opacity and do a delta step*)
-	  match cb2.const_body with
-            | None -> cst
-            | Some lc2 ->
-		let c2 = Declarations.force lc2 in
-		let c1 = match cb1.const_body with
-		  | Some lc1 ->
-		      let c = Declarations.force lc1 in
-			begin
-			  match (kind_of_term c),(kind_of_term c2) with
-			      Const n1,Const n2 when (eq_constant n1 n2) -> c
-				(* c1 may have been strenghtened 
-				   we need to unfold it*)
-			    | Const n,_ ->
-				let cb = subst_const_body subst1
-				  (lookup_constant n env) in
-				  (match cb.const_opaque,
-				     cb.const_body with
-				       | true, Some lc1 ->
-					   Declarations.force lc1
-				       | _,_ -> c)
-			    | _ ,_-> c
-			end
-		  | None -> mkConst con
-		in
-		  check_conv cst conv env c1 c2
-	else
-	  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 con
-		in
-		  check_conv cst conv env c1 c2
-      in
-	cst
+      (* Now we check the bodies:
+	 - A transparent constant can only be implemented by a compatible
+	   transparent constant.
+         - In the signature, an opaque is handled just as a parameter:
+           anything of the right type can implement it, even if bodies differ.
+      *)
+      (match cb2.const_body with
+	| Undef _ | OpaqueDef _ -> cst
+	| Def lc2 ->
+	  (match cb1.const_body with
+	    | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField
+	    | Def lc1 ->
+	      (* NB: cb1 might have been strengthened and appear as transparent.
+		 Anyway [check_conv] will handle that afterwards. *)
+	      let c1 = Declarations.force lc1 in
+	      let c2 = Declarations.force lc2 in
+	      check_conv NotConvertibleBodyField cst conv env c1 c2))
    | IndType ((kn,i),mind1) ->
        ignore (Util.error (
        "The kernel does not recognize yet that a parameter can be " ^
@@ -300,10 +284,10 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
        "inductive type and give a definition to map the old name to the new " ^
        "name."));
       assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if cb2.const_body <> None then error () ;
+      if constant_has_body cb2 then error DefinitionFieldExpected;
       let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
-       check_conv cst conv_leq env arity1 typ2
+       check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2
    | IndConstr (((kn,i),j) as cstr,mind1) ->
       ignore (Util.error (
        "The kernel does not recognize yet that a parameter can be " ^
@@ -311,15 +295,15 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
        "constructor and give a definition to map the old name to the new " ^
        "name."));
       assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if cb2.const_body <> None then error () ;
+      if constant_has_body cb2 then error DefinitionFieldExpected;
       let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
-       check_conv cst conv env ty1 ty2
-   | _ -> error ()
+       check_conv NotConvertibleTypeField cst conv env ty1 ty2
+   | _ -> error DefinitionFieldExpected
 
 let rec check_modules cst env msb1 msb2 subst1 subst2 =
-  let mty1 = module_type_of_module env None msb1 in
-  let mty2 =  module_type_of_module env None msb2 in
+  let mty1 = module_type_of_module None msb1 in
+  let mty2 =  module_type_of_module None msb2 in
   let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
     cst
 
@@ -344,13 +328,13 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
 	      match info1 with
 		| Module msb -> check_modules cst env msb msb2 
 		    subst1 subst2
-		| _ -> error_not_match l spec2
+		| _ -> error_signature_mismatch l spec2 ModuleFieldExpected
 	    end
 	| SFBmodtype mtb2 ->
 	    let mtb1 =
 	      match info1 with
 		| Modtype mtb -> mtb
-		| _ -> error_not_match l spec2
+		| _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
 	    in
 	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
 	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
@@ -368,7 +352,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
 	      if equiv then
 		let subst2 = 
 		  add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
-		Univ.Constraint.union 
+		Univ.union_constraints 
 		  (check_signatures cst env
 		     mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
 		  mtb1.typ_delta mtb2.typ_delta) 
@@ -412,7 +396,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
 let check_subtypes env sup super =
   let env = add_module 
 		(module_body_of_type sup.typ_mp sup) env in
-  check_modtypes Constraint.empty env 
-    (strengthen env sup sup.typ_mp) super empty_subst 
+  check_modtypes empty_constraint env 
+    (strengthen sup sup.typ_mp) super empty_subst
     (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
 
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index a32804b9..cf9cb540 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -1,18 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli 14641 2011-11-06 11:59:10Z herbelin $ 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
index 1894417c..dcb63cf7 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -1,14 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* This module instantiates the structure of generic deBruijn terms to Coq *)
+(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
+(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
+(* Extension to mutual inductive constructions by Christine Paulin for
+   Coq V5.10.2 *)
+(* Extension to co-inductive constructions by Eduardo Gimenez *)
+(* Optimization of substitution functions by Chet Murthy *)
+(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
+   Filliâtre, 1999 *)
+(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+
+(* This file defines the internal syntax of the Calculus of
+   Inductive Constructions (CIC) terms together with constructors,
+   destructors, iterators and basic functions *)
 
 open Util
 open Pp
@@ -16,12 +29,14 @@ 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 the strategy to use for verifiying a Cast *)
+(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
+(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
 
 (* This defines Cases annotations *)
 type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
@@ -31,7 +46,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_nargs : int array; (* number of real args of each constructor *)
+    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -58,8 +73,6 @@ let family_of_sort = function
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
-type cast_kind = VMcast | DEFAULTcast
-
 (* [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
@@ -90,24 +103,6 @@ type ('constr, 'types) kind_of_term =
   | 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
@@ -117,82 +112,10 @@ 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_con,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, k, t) -> Cast (sh_rec c, k, (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_con 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) * (constant -> constant) *
-               (mutual_inductive -> mutual_inductive) * (name -> name) *
-               (identifier -> identifier))
-      let hash_sub = hash_term
-      let equal = comp_term
-      let hash = Hashtbl.hash
-    end)
-
-let hcons_term (hsorts,hcon,hkn,hname,hident) =
-  Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident)
+(*********************)
+(* Term constructors *)
+(*********************)
 
 (* Constructs a DeBrujin index with number n *)
 let rels =
@@ -201,21 +124,20 @@ let rels =
 
 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
+let mkProp   = Sort prop_sort
+let mkSet    = Sort set_sort
+let mkType u = Sort (Type u)
+let mkSort   = function
+  | Prop Null -> mkProp (* Easy sharing *)
+  | Prop Pos -> mkSet
+  | 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)
-   [s] is the strategy to use when *)
+(* (that means t2 is declared as the type of t1) *)
 let mkCast (t1,k2,t2) =
   match t1 with
-  | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2)
+  | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2)
   | _ -> Cast (t1,k2,t2)
 
 (* Constructs the product (x:t1)t2 *)
@@ -236,16 +158,13 @@ let mkApp (f, a) =
       | 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
@@ -256,12 +175,48 @@ 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)
 
+(* 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 fix = Fix fix
 
-let mkCoFix cofix = CoFix cofix
+(* 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 cofix= CoFix cofix
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
 
-let kind_of_term c = c
-let kind_of_term2 c = c
 
 (************************************************************************)
 (*    kind_of_term = constructions as seen by the user                 *)
@@ -271,15 +226,25 @@ let kind_of_term2 c = c
    least one argument and the function is not itself an applicative
    term *)
 
-let kind_of_term = kind_of_term
+let kind_of_term c = c
 
+(* Experimental, used in Presburger contrib *)
+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
 
-(* 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
+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"
 
 (**********************************************************************)
 (*          Non primitive term destructors                            *)
@@ -334,18 +299,12 @@ let rec is_Type c = match kind_of_term c with
   | 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
 
@@ -366,6 +325,7 @@ 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
+let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false
 
 (* Tests if an inductive *)
 let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
@@ -387,7 +347,7 @@ let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 (* 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"
+  | _ -> invalid_arg "destLetIn"
 
 let isLetIn c =  match kind_of_term c with LetIn _ -> true | _ -> false
 
@@ -412,10 +372,6 @@ 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
@@ -485,18 +441,6 @@ let decompose_app c =
     | App (f,cl) -> (f, Array.to_list cl)
     | _ -> (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 Array.length cl2 = 0 then f else mkApp (f,cl2)
-      in
-      collapse_rec f cl
-  | Cast (c,_,_) -> strip_head_cast c
-  | _ -> c
-
 (****************************************************************************)
 (*              Functions to recur through subterms                         *)
 (****************************************************************************)
@@ -621,15 +565,11 @@ let compare_constr f t1 t2 =
   | 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), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+  | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
   | 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
+    Array.length l1 = Array.length l2 &&
+      f c1 c2 && array_for_all2 f l1 l2
   | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
   | Const c1, Const c2 -> eq_constant c1 c2
   | Ind c1, Ind c2 -> eq_ind c1 c2
@@ -642,6 +582,62 @@ let compare_constr f t1 t2 =
       ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
   | _ -> false
 
+(*******************************)
+(*  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 *)
+
+let constr_ord_int f t1 t2 =
+  let (=?) f g i1 i2 j1 j2=
+    let c=f i1 i2 in
+    if c=0 then g j1 j2 else c in
+  let (==?) fg h i1 i2 j1 j2 k1 k2=
+    let c=fg i1 i2 j1 j2 in
+    if c=0 then h k1 k2 else c in
+  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 -> id_ord id1 id2
+    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
+    | Cast (c1,_,_), _ -> f c1 t2
+    | _, Cast (c2,_,_) -> f t1 c2
+    | Prod (_,t1,c1), Prod (_,t2,c2)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+	(f =? f) t1 t2 c1 c2
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+    | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+    | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
+    | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2
+    | Evar (e1,l1), Evar (e2,l2) ->
+	((-) =? (array_compare f)) e1 e2 l1 l2
+    | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2)
+    | Ind (spx, ix), Ind (spy, iy) ->
+	let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c
+    | Construct ((spx, ix), jx), Construct ((spy, iy), jy) ->
+	let c = jx - jy in if c = 0 then
+	  (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c)
+	else c
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+	((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | t1, t2 -> Pervasives.compare t1 t2
+
+let rec constr_ord m n=
+  constr_ord_int constr_ord m n
+
 (***************************************************************************)
 (*     Type of assumptions                                                 *)
 (***************************************************************************)
@@ -659,6 +655,18 @@ let map_rel_declaration = map_named_declaration
 let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
 let fold_rel_declaration = fold_named_declaration
 
+let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
+let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
+
+let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
+let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
+
+let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+  id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
+let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
+  n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
 (***************************************************************************)
 (*     Type of local contexts (telescopes)                                 *)
 (***************************************************************************)
@@ -762,12 +770,12 @@ let rec exliftn el c = match kind_of_term c with
 
 (* Lifting the binding depth across k bindings *)
 
-let liftn k n =
-  match el_liftn (pred n) (el_shft k ELID) with
+let liftn n k =
+  match el_liftn (pred k) (el_shft n el_id) with
     | ELID -> (fun c -> c)
     | el -> exliftn el
 
-let lift k = liftn k 1
+let lift n = liftn n 1
 
 (*********************)
 (*   Substituting    *)
@@ -814,12 +822,12 @@ let substnl laml n =
 let substl laml = substnl laml 0
 let subst1 lam = substl [lam]
 
-let substnl_decl laml k (id,bodyopt,typ) =
-  (id,Option.map (substnl laml k) bodyopt,substnl laml k typ)
+let substnl_decl laml k = map_rel_declaration (substnl laml k)
 let substl_decl laml = substnl_decl laml 0
 let subst1_decl lam = substl_decl [lam]
-let subst1_named_decl = subst1_decl
+let substnl_named laml k = map_named_declaration (substnl laml k)
 let substl_named_decl = substl_decl
+let subst1_named_decl = subst1_decl
 
 (* (thin_val sigma) removes identity substitutions from sigma *)
 
@@ -858,44 +866,12 @@ let substn_vars p vars =
 
 let subst_vars = substn_vars 1
 
-(*********************)
-(* 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 prop_sort
-let mkSet    = mkSort set_sort
-let mkType u = mkSort (Type u)
-let mkSort   = function
-  | Prop Null -> mkProp (* Easy sharing *)
-  | Prop Pos -> mkSet
-  | s -> mkSort 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 = mkCast
+(***************************)
+(* Other term constructors *)
+(***************************)
 
-(* 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] *)
@@ -909,17 +885,6 @@ let mkNamedProd_or_LetIn (id,body,t) c =
     | 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
@@ -934,83 +899,16 @@ let mkNamedProd_wo_LetIn (id,body,t) 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
-
-(***************************)
-(* Other term constructors *)
-(***************************)
+(* 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 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)
+let mkNamedLambda_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedLambda id t c
+    | Some b -> mkNamedLetIn id b t c
 
 (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
 let prodn n env b =
@@ -1252,37 +1150,216 @@ let rec isArity c =
   | Sort _          -> true
   | _               -> false
 
-(*******************************)
-(*  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
+(* Hash-consing of [constr] does not use the module [Hashcons] because
+   [Hashcons] is not efficient on deep tree-like data
+   structures. Indeed, [Hashcons] is based the (very efficient)
+   generic hash function [Hashtbl.hash], which computes the hash key
+   through a depth bounded traversal of the data structure to be
+   hashed. As a consequence, for a deep [constr] like the natural
+   number 1000 (S (S (... (S O)))), the same hash is assigned to all
+   the sub [constr]s greater than the maximal depth handled by
+   [Hashtbl.hash]. This entails a huge number of collisions in the
+   hash table and leads to cubic hash-consing in this worst-case.
+
+   In order to compute a hash key that is independent of the data
+   structure depth while being constant-time, an incremental hashing
+   function must be devised. A standard implementation creates a cache
+   of the hashing function by decorating each node of the hash-consed
+   data structure with its hash key. In that case, the hash function
+   can deduce the hash key of a toplevel data structure by a local
+   computation based on the cache held on its substructures.
+   Unfortunately, this simple implementation introduces a space
+   overhead that is damageable for the hash-consing of small [constr]s
+   (the most common case). One can think of an heterogeneous
+   distribution of caches on smartly chosen nodes, but this is forbidden
+   by the use of generic equality in Coq source code. (Indeed, this forces
+   each [constr] to have a unique canonical representation.)
+
+   Given that hash-consing proceeds inductively, we can nonetheless
+   computes the hash key incrementally during hash-consing by changing
+   a little the signature of the hash-consing function: it now returns
+   both the hash-consed term and its hash key. This simple solution is
+   implemented in the following code: it does not introduce a space
+   overhead in [constr], that's why the efficiency is unchanged for
+   small [constr]s. Besides, it does handle deep [constr]s without
+   introducing an unreasonable number of collisions in the hash table.
+   Some benchmarks make us think that this implementation of
+   hash-consing is linear in the size of the hash-consed data
+   structure for our daily use of Coq.
 *)
-(**)
-      let hash_sub (hc,hs) j = hc j
-      let equal j1 j2 = j1==j2
-(**)
-      let hash = Hashtbl.hash
-    end)
+
+let array_eqeq t1 t2 =
+  t1 == t2 ||
+  (Array.length t1 = Array.length t2 &&
+   let rec aux i =
+     (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1))
+   in aux 0)
+
+let equals_constr 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,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & 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_eqeq l1 l2
+    | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq 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_eqeq bl1 bl2
+    | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_eqeq lna1 lna2
+      & array_eqeq tl1 tl2
+      & array_eqeq bl1 bl2
+    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_eqeq lna1 lna2
+      & array_eqeq tl1 tl2
+      & array_eqeq bl1 bl2
+    | _ -> false
+
+(** Note that the following Make has the side effect of creating
+    once and for all the table we'll use for hash-consing all constr *)
+
+module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end)
+
+open Hashtbl_alt.Combine
+
+(* [hcons_term hash_consing_functions constr] computes an hash-consed
+   representation for [constr] using [hash_consing_functions] on
+   leaves. *)
+let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
+
+  (* Note : we hash-cons constr arrays *in place* *)
+
+  let rec hash_term_array t =
+    let accu = ref 0 in
+    for i = 0 to Array.length t - 1 do
+      let x, h = sh_rec t.(i) in
+      accu := combine !accu h;
+      t.(i) <- x
+    done;
+    !accu
+
+  and hash_term t =
+    match t with
+      | Var i ->
+	(Var (sh_id i), combinesmall 1 (Hashtbl.hash i))
+      | Sort s ->
+	(Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s))
+      | Cast (c, k, t) ->
+	let c, hc = sh_rec c in
+	let t, ht = sh_rec t in
+	(Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht))
+      | Prod (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc))
+      | Lambda (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc))
+      | LetIn (na,b,t,c) ->
+	let b, hb = sh_rec b in
+	let t, ht = sh_rec t in
+	let c, hc = sh_rec c in
+	(LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc))
+      | App (c,l) ->
+	let c, hc = sh_rec c in
+	let hl = hash_term_array l in
+	(App (c, l), combinesmall 7 (combine hl hc))
+      | Evar (e,l) ->
+	let hl = hash_term_array l in
+	(* since the array have been hashed in place : *)
+	(t, combinesmall 8 (combine (Hashtbl.hash e) hl))
+      | Const c ->
+	(Const (sh_con c), combinesmall 9 (Hashtbl.hash c))
+      | Ind ((kn,i) as ind) ->
+	(Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i))
+      | Construct (((kn,i),j) as c)->
+	(Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j))
+      | Case (ci,p,c,bl) ->
+	let p, hp = sh_rec p
+	and c, hc = sh_rec c in
+	let hbl = hash_term_array bl in
+	let hbl = combine (combine hc hp) hbl in
+	(Case (sh_ci ci, p, c, bl), combinesmall 11 hbl)
+      | Fix (ln,(lna,tl,bl)) ->
+	let hbl = hash_term_array  bl in
+	let htl = hash_term_array  tl in
+	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+	(* since the three arrays have been hashed in place : *)
+	(t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl)))
+      | CoFix(ln,(lna,tl,bl)) ->
+	let hbl = hash_term_array bl in
+	let htl = hash_term_array tl in
+	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+	(* since the three arrays have been hashed in place : *)
+	(t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl)))
+      | Meta n ->
+	(t, combinesmall 15 n)
+      | Rel n ->
+	(t, combinesmall 16 n)
+
+  and sh_rec t =
+    let (y, h) = hash_term t in
+    (* [h] must be positive. *)
+    let h = h land 0x3FFFFFFF in
+    (H.may_add_and_get h y, h)
+
+  in
+  (* Make sure our statically allocated Rels (1 to 16) are considered
+     as canonical, and hence hash-consed to themselves *)
+  ignore (hash_term_array rels);
+
+  fun t -> fst (sh_rec t)
+
+(* Exported hashing fonction on constr, used mainly in plugins.
+   Appears to have slight differences from [snd (hash_term t)] above ? *)
+
+let rec hash_constr t =
+  match kind_of_term t with
+    | Var i -> combinesmall 1 (Hashtbl.hash i)
+    | Sort s -> combinesmall 2 (Hashtbl.hash s)
+    | Cast (c, _, _) -> hash_constr c
+    | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c))
+    | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c))
+    | LetIn (_, b, t, c) ->
+      combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c))
+    | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l))
+    | App (c,l) ->
+      combinesmall 7 (combine (hash_term_array l) (hash_constr c))
+    | Evar (e,l) ->
+      combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l))
+    | Const c ->
+      combinesmall 9 (Hashtbl.hash c)	(* TODO: proper hash function for constants *)
+    | Ind (kn,i) ->
+      combinesmall 9 (combine (Hashtbl.hash kn) i)
+    | Construct ((kn,i),j) ->
+      combinesmall 10 (combine3 (Hashtbl.hash kn) i j)
+    | Case (_ , p, c, bl) ->
+      combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl))
+    | Fix (ln ,(_, tl, bl)) ->
+      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
+    | CoFix(ln, (_, tl, bl)) ->
+       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
+    | Meta n -> combinesmall 15 n
+    | Rel n -> combinesmall 16 n
+
+and hash_term_array t =
+  Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t
 
 module Hsorts =
   Hashcons.Make(
@@ -1300,16 +1377,34 @@ module Hsorts =
       let hash = Hashtbl.hash
     end)
 
-let hsort = Hsorts.f
+module Hcaseinfo =
+  Hashcons.Make(
+    struct
+      type t = case_info
+      type u = inductive -> inductive
+      let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind }
+      let equal ci ci' =
+	ci.ci_ind == ci'.ci_ind &&
+	ci.ci_npar = ci'.ci_npar &&
+	ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *)
+	ci.ci_pp_info = ci'.ci_pp_info  (* we use (=) on purpose *)
+      let hash = Hashtbl.hash
+    end)
 
-let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) =
-  let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
-  let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in
-  let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
-  (hcci,htcci)
+let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ
+let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind
 
-let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
+let hcons_constr =
+  hcons_term
+    (hcons_sorts,
+     hcons_caseinfo,
+     hcons_construct,
+     hcons_ind,
+     hcons_con,
+     hcons_name,
+     hcons_ident)
 
+let hcons_types = hcons_constr
 
 (*******)
 (* Type of abstract machine values *)
diff --git a/kernel/term.mli b/kernel/term.mli
index c9a97bbe..d5899f18 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -1,169 +1,176 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
-(*i*)
 
 
-(*s The sorts of CCI. *)
+(** {6 The sorts of CCI. } *)
 
 type contents = Pos | Null
 
 type sorts =
-  | Prop of contents       (* Prop and Set *)
-  | Type of Univ.universe  (* Type *)
+  | Prop of contents       (** Prop and Set *)
+  | Type of Univ.universe  (** Type *)
 
 val set_sort  : sorts
 val prop_sort : sorts
 val type1_sort  : sorts
 
-(*s The sorts family of CCI. *)
+(** {6 The sorts family of CCI. } *)
 
 type sorts_family = InProp | InSet | InType
 
 val family_of_sort : sorts -> sorts_family
 
-(*s Useful types *)
+(** {6 Useful types } *)
 
-(*s Existential variables *)
+(** {6 Existential variables } *)
 type existential_key = int
 
-(*s Existential variables *)
+(** {6 Existential variables } *)
 type metavariable = int
 
-(*s Case annotation *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
+(** {6 Case annotation } *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle 
+  | RegularStyle (** infer printing form from number of constructor *)
 type case_printing =
-  { ind_nargs : int; (* length of the arity of the inductive type *)
+  { ind_nargs : int; (** length of the arity of the inductive type *)
     style     : case_style }
-(* the integer is the number of real args, needed for reduction *)
+
+(** the integer is the number of real args, needed for reduction *)
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_nargs : int array; (* number of real args of each constructor *)
-    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+    ci_cstr_ndecls : int array; (** number of real args of each constructor *)
+    ci_pp_info    : case_printing (** not interpreted by the kernel *)
   }
 
-(*s*******************************************************************)
-(* The type of constructions *)
+(** {6 The type of constructions } *)
 
 type constr
 
-(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
+(** [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 for
+(** [types] is the same as [constr] but is intended to be used for
    documentation to indicate that such or such function specifically works
-   with {\em types} (i.e. terms of type a sort).
+   with {e types} (i.e. terms of type a sort).
    (Rem:plurial form since [type] is a reserved ML keyword) *)
 
 type types = constr
 
-(*s Functions for dealing with constr terms.
+(** {5 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. *)
+(** {6 Term constructors. } *)
 
-(* Constructs a DeBrujin index (DB indices begin at 1) *)
+(** Constructs a DeBrujin index (DB indices begin at 1) *)
 val mkRel : int -> constr
 
-(* Constructs a Variable *)
+(** Constructs a Variable *)
 val mkVar : identifier -> constr
 
-(* Constructs an patvar named "?n" *)
+(** Constructs an patvar named "?n" *)
 val mkMeta : metavariable -> constr
 
-(* Constructs an existential variable *)
+(** Constructs an existential variable *)
 type existential = existential_key * constr array
 val mkEvar : existential -> constr
 
-(* Construct a sort *)
+(** Construct a sort *)
 val mkSort : sorts -> types
 val mkProp : types
 val mkSet  : types
 val mkType : Univ.universe -> types
 
 
-(* This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast
+(** This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
 
-(* 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). *)
+(** 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 * cast_kind * constr -> constr
 
-(* Constructs the product [(x:t1)t2] *)
+(** 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))] *)
+
+(** non-dependent product [t1 -> t2], an alias for
+   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
+   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
+*)
 val mkArrow : types -> types -> constr
 
-(* Constructs the abstraction $[x:t_1]t_2$ *)
+(** 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] *)
+(** 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)$. *)
+(** [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 *)
+(** Constructs a constant 
+   The array of terms correspond to the variables introduced in the section *)
 val mkConst : constant -> constr
 
-(* Inductive types *)
+(** 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 *)
+(** 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
+(** 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 *)
+(** Constructs a destructor of inductive type.
+    
+    [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] 
+    presented as describe in [ci].
+
+    [p] stucture is [fun args x -> "return clause"]
+
+    [ac]{^ ith} element is ith constructor case presented as 
+    {e lambda construct_args (without params). case_term } *)
 val mkCase : case_info * constr * constr * constr array -> constr
 
-(* If [recindxs = [|i1,...in|]]
+(** 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)
+   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$.
+   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|]]
+(** If [funnames = [|f1,.....fn|]]
       [typarray = [|t1,...tn|]]
-      [bodies   = [b1,.....bn]] \par\noindent
-   then [mkCoFix (i, (typsarray, funnames, bodies))]
+      [bodies   = [b1,.....bn]] 
+   then [mkCoFix (i, (funnames, typarray, bodies))]
    constructs the ith function of the block
-
+   
     [CoFixpoint f1 = b1
      with       f2 = b2
      ...
@@ -173,9 +180,9 @@ type cofixpoint = int * rec_declaration
 val mkCoFix : cofixpoint -> constr
 
 
-(*s Concrete type for making pattern-matching. *)
+(** {6 Concrete type for making pattern-matching. } *)
 
-(* [constr array] is an instance matching definitional [named_context] in
+(** [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 =
@@ -203,14 +210,13 @@ type ('constr, 'types) kind_of_term =
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
 
-(* User view of [constr]. For [App], it is ensured there is at
+(** 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
-val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term
 
-(* Experimental *)
+(** Experimental, used in Presburger contrib *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
   | CastType   of 'types * 'types
@@ -220,10 +226,11 @@ type ('constr, 'types) kind_of_type =
 
 val kind_of_type : types -> (constr, types) kind_of_type
 
-(*s Simple term case analysis. *)
+(** {6 Simple term case analysis. } *)
 
 val isRel  : constr -> bool
 val isVar  : constr -> bool
+val isVarId  : identifier -> constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
@@ -247,77 +254,83 @@ 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 *)
+(** {6 Term destructors } *)
+(** Destructor operations are partial functions and
+    @raise Invalid_argument "dest*" if the term has not the expected form. *)
+
+(** Destructs a DeBrujin index *)
 val destRel : constr -> int
 
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
 val destMeta : constr -> metavariable
 
-(* Destructs a variable *)
+(** 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}. *)
+(** 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 *)
+(** Destructs a casted term *)
 val destCast : constr -> constr * cast_kind * constr
 
-(* Destructs the product $(x:t_1)t_2$ *)
+(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
 val destProd : types -> name * types * types
 
-(* Destructs the abstraction $[x:t_1]t_2$ *)
+(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
 val destLambda : constr -> name * types * constr
 
-(* Destructs the let $[x:=b:t_1]t_2$ *)
+(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
 val destLetIn : constr -> name * constr * types * constr
 
-(* Destructs an application *)
+(** Destructs an application *)
 val destApp : constr -> constr * constr array
 
-(* Obsolete synonym of destApp *)
+(** Obsolete synonym of destApp *)
 val destApplication : constr -> constr * constr array
 
-(* Decompose any term as an applicative term; the list of args can be empty *)
+(** Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
-(* Destructs a constant *)
+(** Destructs a constant *)
 val destConst : constr -> constant
 
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
 val destEvar : constr -> existential
 
-(* Destructs a (co)inductive type *)
+(** Destructs a (co)inductive type *)
 val destInd : constr -> inductive
 
-(* Destructs a constructor *)
+(** Destructs a constructor *)
 val destConstruct : constr -> constructor
 
-(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+(** Destructs a [match c as x in I args return P with ... |
+Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
+return P in t1], or [if c then t1 else t2])
+@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])]
+where [info] is pretty-printing information *)
 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$.
+(** Destructs the {% $ %}i{% $ %}th function of the block
+   [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
+    with    f{_ 2} ctx{_ 2} = b{_ 2}
+    ...
+    with    f{_ n} ctx{_ n} = b{_ n}],
+   where the length 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
+(** {6 Local } *)
+(** A {e declaration} has the form [(name,body,type)]. It is either an
+    {e assumption} if [body=None] or a {e definition} if
+    [body=Some actualbody]. It is referred by {e name} if [na] is an
+    identifier or by {e relative index} if [na] is not an identifier
     (in the latter case, [na] is of type [name] but just for printing
-    purpose *)
+    purpose) *)
 
 type named_declaration = identifier * constr option * types
 type rel_declaration = name * constr option * types
@@ -332,9 +345,25 @@ val fold_named_declaration :
 val fold_rel_declaration :
   (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
 
-(*s Contexts of declarations referred to by de Bruijn indices *)
+val exists_named_declaration :
+  (constr -> bool) -> named_declaration -> bool
+val exists_rel_declaration :
+  (constr -> bool) -> rel_declaration -> bool
 
-(* In [rel_context], more recent declaration is on top *)
+val for_all_named_declaration :
+  (constr -> bool) -> named_declaration -> bool
+val for_all_rel_declaration :
+  (constr -> bool) -> rel_declaration -> bool
+
+val eq_named_declaration :
+  named_declaration -> named_declaration -> bool
+
+val eq_rel_declaration :
+    rel_declaration -> rel_declaration -> bool
+
+(** {6 Contexts of declarations referred to 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
@@ -344,185 +373,186 @@ val lookup_rel : int -> rel_context -> rel_declaration
 val rel_context_length : rel_context -> int
 val rel_context_nhyps : rel_context -> int
 
-(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+(** Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkProd_wo_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] *)
+(** 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. *)
+(** {6 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] *)
+(** [applist (f,args)] and its variants 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]$ *)
+(** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
 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)]$.
+(** [compose_prod l b]
+   @return [forall (x_1:T_1)...(x_n:T_n), b]
+   where [l] is [(x_n,T_n)...(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]$ *)
+(** [lamn n l b]
+    @return [fun (x_1:T_1)...(x_n:T_n) => b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
 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)]$.
+(** [compose_lam l b]
+   @return [fun (x_1:T_1)...(x_n:T_n) => b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)].
    Inverse of [it_destLam] *)
 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$ *)
+(** [to_lambda n l]
+   @return [fun (x_1:T_1)...(x_n:T_n) => T]
+   where [l] is [forall (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$ *)
+(** [to_prod n l]
+   @return [forall (x_1:T_1)...(x_n:T_n), T]
+   where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *)
 val to_prod : int -> constr -> constr
 
-(* pseudo-reduction rule *)
+(** pseudo-reduction rule *)
 
-(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *)
+(** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
 val prod_appvect : constr -> constr array -> constr
 val prod_applist : constr -> constr list -> constr
 
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
 val it_mkProd_or_LetIn : types -> rel_context -> types
 
-(*s Other term destructors. *)
+(** {6 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.
+(** 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. *)
+(** 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)$. *)
+(** 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)$ *)
+(** 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
 
-(* Extract the premisses and the conclusion of a term of the form
+(** Extract the premisses and the conclusion of a term of the form
    "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *)
 val decompose_prod_assum : types -> rel_context * types
 
-(* Idem with lambda's *)
+(** Idem with lambda's *)
 val decompose_lam_assum : constr -> rel_context * constr
 
-(* Idem but extract the first [n] premisses *)
+(** Idem but extract the first [n] premisses *)
 val decompose_prod_n_assum : int -> types -> rel_context * types
 val decompose_lam_n_assum : int -> constr -> rel_context * constr
 
-(* [nb_lam] $[x_1:T_1]...[x_n:T_n]c$ where $c$ is not an abstraction
-   gives $n$ (casts are ignored) *)
+(** [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 *)
+(** Similar to [nb_lam], but gives the number of products instead *)
 val nb_prod : constr -> int
 
-(* Returns the premisses/parameters of a type/term (let-in included) *)
+(** Returns the premisses/parameters of a type/term (let-in included) *)
 val prod_assum : types -> rel_context
 val lam_assum : constr -> rel_context
 
-(* Returns the first n-th premisses/parameters of a type/term (let included)*)
+(** Returns the first n-th premisses/parameters of a type/term (let included)*)
 val prod_n_assum : int -> types -> rel_context
 val lam_n_assum : int -> constr -> rel_context
 
-(* Remove the premisses/parameters of a type/term *)
+(** Remove the premisses/parameters of a type/term *)
 val strip_prod : types -> types
 val strip_lam : constr -> constr
 
-(* Remove the first n-th premisses/parameters of a type/term *)
+(** Remove the first n-th premisses/parameters of a type/term *)
 val strip_prod_n : int -> types -> types
 val strip_lam_n : int -> constr -> constr
 
-(* Remove the premisses/parameters of a type/term (including let-in) *)
+(** Remove the premisses/parameters of a type/term (including let-in) *)
 val strip_prod_assum : types -> types
 val strip_lam_assum : constr -> constr
 
-(* flattens application lists *)
+(** 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]. *)
+(** 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 *)
+(** Apply a function letting Casted types in place *)
 val under_casts : (constr -> constr) -> constr -> constr
 
-(* Apply a function under components of Cast if any *)
+(** Apply a function under components of Cast if any *)
 val under_outer_cast : (constr -> constr) -> constr -> constr
 
-(*s An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
+(** {6 ... } *)
+(** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
     Such a term can canonically be seen as the pair of a context of types
     and of a sort *)
 
 type arity = rel_context * sorts
 
-(* Build an "arity" from its canonical form *)
+(** Build an "arity" from its canonical form *)
 val mkArity : arity -> types
 
-(* Destructs an "arity" into its canonical form *)
+(** Destructs an "arity" into its canonical form *)
 val destArity : types -> arity
 
-(* Tells if a term has the form of an arity *)
+(** Tells if a term has the form of an arity *)
 val isArity : types -> bool
 
-(*s Occur checks *)
+(** {6 Occur checks } *)
 
-(* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
 val closedn : int -> constr -> bool
 
-(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+(** [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]  *)
+(** [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]
+(** [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
+(** Checking function for terms containing existential- or
    meta-variables.  The function [noccur_with_meta] does not consider
    meta-variables applied to some terms (intended 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 *)
+(** {6 Relocation and substitution } *)
 
-(* [exliftn el c] lifts [c] with lifting [el] *)
+(** [exliftn el c] lifts [c] with lifting [el] *)
 val exliftn : Esubst.lift -> constr -> constr
 
-(* [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
+(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
 val liftn : int -> int -> constr -> constr
 
-(* [lift n c] lifts by [n] the positive indexes in [c] *)
+(** [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]
+(** [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
@@ -539,29 +569,30 @@ val substl_named_decl : constr list -> 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]
+(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
    if two names are identical, the one of least indice is kept *)
 val subst_vars : identifier list -> constr -> constr
-(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+
+(** [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 kept *)
 val substn_vars : int -> identifier list -> constr -> constr
 
 
-(*s Functionals working on the immediate subterm of a construction *)
+(** {6 Functionals working on the immediate subterm of a construction } *)
 
-(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+(** [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
+(** [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
+(** [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
@@ -570,13 +601,13 @@ val map_constr : (constr -> constr) -> constr -> constr
 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
+(** [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
+(** [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
@@ -585,27 +616,20 @@ val iter_constr : (constr -> unit) -> constr -> unit
 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
+(** [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 constr_ord : constr -> constr -> int
+val hash_constr : constr -> int
+
 (*********************************************************************)
 
-val hcons_constr:
-  (constant -> constant) *
-  (mutual_inductive -> mutual_inductive) *
-  (dir_path -> dir_path) *
-  (name -> name) *
-  (identifier -> identifier) *
-  (string -> string)
-  ->
-    (constr -> constr) *
-    (types -> types)
-
-val hcons1_constr : constr -> constr
-val hcons1_types : types -> types
+val hcons_sorts : sorts -> sorts
+val hcons_constr : constr -> constr
+val hcons_types : types -> types
 
 (**************************************)
 
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index c1eb97a6..478b9c6f 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -1,12 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module provides the main entry points for type-checking basic
+   declarations *)
 
 open Util
 open Names
@@ -28,8 +32,9 @@ let constrain_type env j cst1 = function
   | Some t ->
       let (tj,cst2) = infer_type env t in
       let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
-      assert (t = tj.utj_val);
-      NonPolymorphicType t, Constraint.union (Constraint.union cst1 cst2) cst3
+	assert (eq_constr t tj.utj_val);
+	let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in
+	  NonPolymorphicType t, cstrs
 
 let local_constrain_type env j cst1 = function
   | None ->
@@ -37,8 +42,8 @@ let local_constrain_type env j cst1 = function
   | Some t ->
       let (tj,cst2) = infer_type env t in
       let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
-      assert (t = tj.utj_val);
-      t, Constraint.union (Constraint.union cst1 cst2) cst3
+      assert (eq_constr t tj.utj_val);
+      t, union_constraints (union_constraints cst1 cst2) cst3
 
 let translate_local_def env (b,topt) =
   let (j,cst) = infer env b in
@@ -88,13 +93,20 @@ let infer_declaration env dcl =
   match dcl with
   | DefinitionEntry c ->
       let (j,cst) = infer env c.const_entry_body in
+      let j =
+        {uj_val = hcons_constr j.uj_val;
+         uj_type = hcons_constr j.uj_type} 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, c.const_entry_boxed, false
-  | ParameterEntry (t,nl) ->
+      let def =
+	if c.const_entry_opaque
+	then OpaqueDef (Declarations.opaque_from_val j.uj_val)
+	else Def (Declarations.from_val j.uj_val)
+      in
+      def, typ, cst, c.const_entry_secctx
+  | ParameterEntry (ctx,t,nl) ->
       let (j,cst) = infer env t in
-      None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst,
-        false, false, nl
+      let t = hcons_constr (Typeops.assumption_of_judgment env j) in
+      Undef nl, NonPolymorphicType t, cst, ctx
 
 let global_vars_set_constant_type env = function
   | NonPolymorphicType t -> global_vars_set env t
@@ -104,25 +116,32 @@ let global_vars_set_constant_type env = function
 	  (fun t c -> Idset.union (global_vars_set env t) c))
       ctx ~init:Idset.empty
 
-let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) =
-  let ids =
-    match body with
-    | None -> global_vars_set_constant_type env typ
-    | Some b ->
-        Idset.union
-	  (global_vars_set env (Declarations.force b))
-	  (global_vars_set_constant_type env typ)
-  in
-  let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in
-  let hyps = keep_hyps env ids in
-    { const_hyps = hyps;
-      const_body = body;
-      const_type = typ;
-      const_body_code = tps;
-     (* const_type_code = to_patch env typ;*)
-      const_constraints = cst;
-      const_opaque = op;
-      const_inline = inline}
+let build_constant_declaration env kn (def,typ,cst,ctx) =
+  let hyps = 
+    let inferred =
+      let ids_typ = global_vars_set_constant_type env typ in
+      let ids_def = match def with
+      | Undef _ -> Idset.empty
+      | Def cs -> global_vars_set env (Declarations.force cs)
+      | OpaqueDef lc -> 
+          global_vars_set env (Declarations.force_opaque lc) in
+      keep_hyps env (Idset.union ids_typ ids_def) in
+    let declared = match ctx with
+      | None -> inferred 
+      | Some declared -> declared in
+    let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in
+    let inferred_set, declared_set = mk_set inferred, mk_set declared in
+    if not (Idset.subset inferred_set declared_set) then
+      error ("The following section variable are used but not declared:\n"^
+        (String.concat ", " (List.map string_of_id
+          (Idset.elements (Idset.diff inferred_set declared_set)))));
+    declared in
+  let tps = Cemitcodes.from_val (compile_constant_body env def) in
+  { const_hyps = hyps;
+    const_body = def;
+    const_type = typ;
+    const_body_code = tps;
+    const_constraints = cst }
 
 (*s Global and local constant declaration. *)
 
@@ -130,8 +149,9 @@ let translate_constant env kn ce =
   build_constant_declaration env kn (infer_declaration env ce)
 
 let translate_recipe env kn r =
-  build_constant_declaration env kn (Cooking.cook_constant env r)
+  build_constant_declaration env kn 
+    (let def,typ,cst = Cooking.cook_constant env r in def,typ,cst,None)
 
 (* Insertion of inductive types. *)
 
-let translate_mind env mie = check_inductive env mie
+let translate_mind env kn mie = check_inductive env kn mie
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 217c9f91..3bbf5667 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Univ
@@ -17,7 +14,6 @@ open Inductive
 open Environ
 open Entries
 open Typeops
-(*i*)
 
 val translate_local_def : env -> constr * types option ->
   constr * types * Univ.constraints
@@ -26,16 +22,16 @@ val translate_local_assum : env -> types ->
   types * Univ.constraints
 
 val infer_declaration : env -> constant_entry ->
-   constr_substituted option * constant_type * constraints * bool * bool * bool
+  constant_def * constant_type * constraints * Sign.section_context option
 
 val build_constant_declaration : env -> 'a ->
-    constr_substituted option * constant_type * constraints * bool * bool * bool ->
-      constant_body
+  constant_def * constant_type * constraints * Sign.section_context option -> 
+    constant_body
 
 val translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind :
-  env -> mutual_inductive_entry -> mutual_inductive_body
+  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
 
 val translate_recipe :
   env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 2e6b8d50..8f129999 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Sign
@@ -20,7 +18,7 @@ type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
   | CodomainNotInductiveType of constr
@@ -50,7 +48,7 @@ type type_error =
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * int * constr * constr
+  | IllFormedBranch of constr * constructor * constr * constr
   | Generalization of (name * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
@@ -111,4 +109,9 @@ let error_ill_formed_rec_body env why lna i fixenv vdefj =
 let error_ill_typed_rec_body env i lna vdefj vargs =
   raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
 
+let error_elim_explain kp ki =
+  match kp,ki with
+  | (InType | InSet), InProp -> NonInformativeToInformative
+  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
+  | _ -> WrongArity
 
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 989b8fbb..7c61e105 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Environ
-(*i*)
 
-(* Type errors. \label{typeerrors} *)
+(** Type errors. {% \label{%}typeerrors{% }%} *)
 
 (*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
     notation i*)
 type guard_error =
-  (* Fixpoints *)
+  (** Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
-  (* CoFixpoints *)
+  (** CoFixpoints *)
   | CodomainNotInductiveType of constr
   | NestedRecursiveOccurrences
   | UnguardedRecursiveCall of constr
@@ -52,7 +48,7 @@ type type_error =
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * int * constr * constr
+  | IllFormedBranch of constr * constructor * constr * constr
   | Generalization of (name * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
@@ -82,7 +78,7 @@ 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_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a
 
 val error_generalization : env -> name * types -> unsafe_judgment -> 'a
 
@@ -101,3 +97,4 @@ val error_ill_formed_rec_body :
 val error_ill_typed_rec_body  :
   env -> int -> name array -> unsafe_judgment array -> types array -> 'a
 
+val error_elim_explain : sorts_family -> sorts_family -> arity_error
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 2fd02063..49106c91 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -20,8 +18,7 @@ open Reduction
 open Inductive
 open Type_errors
 
-let conv = default_conv CONV
-let conv_leq = default_conv CUMUL
+let conv_leq l2r = default_conv CUMUL ~l2r
 
 let conv_leq_vecti env v1 v2 =
   array_fold_left2_i
@@ -29,8 +26,8 @@ let conv_leq_vecti env v1 v2 =
       let c' =
         try default_conv CUMUL env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
-      Constraint.union c c')
-    Constraint.empty
+      union_constraints c c')
+    empty_constraint
     v1
     v2
 
@@ -47,8 +44,6 @@ let assumption_of_judgment env j =
   with TypeError _ ->
     error_assumption env j
 
-let sort_judgment env j = (type_judgment env j).utj_type
-
 (************************************************)
 (* Incremental typing rules: builds a typing judgement given the *)
 (* judgements for the subterms. *)
@@ -206,8 +201,8 @@ let judge_of_apply env funj argjv =
         (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
+		let c = conv_leq false env hj.uj_type c1 in
+		let cst' = union_constraints cst c in
 		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
 	      with NotConvertible ->
 		error_cant_apply_bad_type env
@@ -219,7 +214,7 @@ let judge_of_apply env funj argjv =
   in
   apply_rec 1
     funj.uj_type
-    Constraint.empty
+    empty_constraint
     (Array.to_list argjv)
 
 (* Type of product *)
@@ -270,11 +265,18 @@ let judge_of_product env name t1 t2 =
 let judge_of_cast env cj k tj =
   let expected_type = tj.utj_val in
   try
-    let cst =
+    let c, cst =
       match k with
-      | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
-      | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
-    { uj_val = mkCast (cj.uj_val, k, expected_type);
+      | VMcast ->
+          mkCast (cj.uj_val, k, expected_type),
+          vm_conv CUMUL env cj.uj_type expected_type
+      | DEFAULTcast ->
+          mkCast (cj.uj_val, k, expected_type),
+          conv_leq false env cj.uj_type expected_type
+      | REVERTcast ->
+          cj.uj_val,
+          conv_leq true env cj.uj_type expected_type in
+    { uj_val = c;
       uj_type = expected_type },
     cst
   with NotConvertible ->
@@ -318,11 +320,11 @@ let judge_of_constructor env c =
 
 (* Case. *)
 
-let check_branch_types env cj (lfj,explft) =
+let check_branch_types env ind cj (lfj,explft) =
   try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
+        error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
@@ -333,11 +335,11 @@ let judge_of_case env ci pj cj lfj =
   let _ = check_case_info env (fst indspec) ci in
   let (bty,rslty,univ) =
     type_case_branches env indspec pj cj.uj_val in
-  let univ' = check_branch_types env cj (lfj,bty) in
+  let univ' = check_branch_types env (fst indspec) cj (lfj,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')
+  union_constraints univ univ')
 
 (* Fixpoints. *)
 
@@ -359,7 +361,7 @@ let type_fixpoint env lna lar vdefj =
    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))
+  (j,(union_constraints cst c', merge_constraints c' univ))
 
 (* The typing machine. *)
     (* ATTENTION : faudra faire le typage du contexte des Const,
@@ -476,23 +478,21 @@ and execute_recdef env (names,lar,vdef) i cu =
 
 and execute_array env = array_fold_map' (execute env)
 
-and execute_list env = list_fold_map' (execute env)
-
 (* Derived functions *)
 let infer env constr =
   let (j,(cst,_)) =
-    execute env constr (Constraint.empty, universes env) in
-  assert (j.uj_val = constr);
-  ({ j with uj_val = constr }, cst)
+    execute env constr (empty_constraint, universes env) in
+  assert (eq_constr j.uj_val constr);
+  (j, cst)
 
 let infer_type env constr =
   let (j,(cst,_)) =
-    execute_type env constr (Constraint.empty, universes env) in
+    execute_type env constr (empty_constraint, universes env) in
   (j, cst)
 
 let infer_v env cv =
   let (jv,(cst,_)) =
-    execute_array env cv (Constraint.empty, universes env) in
+    execute_array env cv (empty_constraint, universes env) in
   (jv, cst)
 
 (* Typing of several terms. *)
@@ -510,8 +510,8 @@ let infer_local_decls env decls =
   | (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
+      push_rel d env, add_rel_decl d l, union_constraints cst1 cst2
+  | [] -> env, empty_rel_context, empty_constraint in
   inferec env decls
 
 (* Exported typing functions *)
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 6e922041..c1c805f3 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Environ
 open Entries
 open Declarations
-(*i*)
 
-(*s Typing functions (not yet tagged as safe) *)
+(** {6 Typing functions (not yet tagged as safe) } *)
 
 val infer      : env -> constr       -> unsafe_judgment * constraints
 val infer_v    : env -> constr array -> unsafe_judgment array * constraints
@@ -27,56 +23,56 @@ val infer_local_decls :
   env -> (identifier * local_entry) list
     -> env * rel_context * constraints
 
-(*s Basic operations of the typing machine. *)
+(** {6 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. *)
+(** 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. *)
+(** {6 Type of sorts. } *)
 val judge_of_prop_contents : contents -> unsafe_judgment
 val judge_of_type          : universe -> unsafe_judgment
 
-(*s Type of a bound variable. *)
+(** {6 Type of a bound variable. } *)
 val judge_of_relative : env -> int -> unsafe_judgment
 
-(*s Type of variables *)
+(** {6 Type of variables } *)
 val judge_of_variable : env -> variable -> unsafe_judgment
 
-(*s type of a constant *)
+(** {6 type of a constant } *)
 val judge_of_constant : env -> constant -> unsafe_judgment
 
 val judge_of_constant_knowing_parameters :
   env -> constant -> unsafe_judgment array -> unsafe_judgment
 
-(*s Type of application. *)
+(** {6 Type of application. } *)
 val judge_of_apply :
   env -> unsafe_judgment -> unsafe_judgment array
     -> unsafe_judgment * constraints
 
-(*s Type of an abstraction. *)
+(** {6 Type of an abstraction. } *)
 val judge_of_abstraction :
   env -> name -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
-(*s Type of a product. *)
+(** {6 Type of a product. } *)
 val judge_of_product :
   env -> name -> unsafe_type_judgment -> unsafe_type_judgment
     -> unsafe_judgment
 
-(* s Type of a let in. *)
+(** 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. *)
+(** {6 Type of a cast. } *)
 val judge_of_cast :
   env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
     unsafe_judgment * constraints
 
-(*s Inductive types. *)
+(** {6 Inductive types. } *)
 
 val judge_of_inductive : env -> inductive -> unsafe_judgment
 
@@ -85,16 +81,16 @@ val judge_of_inductive_knowing_parameters :
 
 val judge_of_constructor : env -> constructor -> unsafe_judgment
 
-(*s Type of Cases. *)
+(** {6 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) *)
+(** 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 *)
+(** Kernel safe typing but applicable to partial proofs *)
 val typing : env -> constr -> unsafe_judgment
 
 val type_of_constant : env -> constant -> types
@@ -104,7 +100,7 @@ val type_of_constant_type : env -> constant_type -> types
 val type_of_constant_knowing_parameters :
   env -> constant_type -> constr array -> types
 
-(* Make a type polymorphic if an arity *)
+(** Make a type polymorphic if an arity *)
 val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
   constant_type
 
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 0646a501..a8934544 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -1,17 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
-(* Extension with algebraic universes by HH [Sep 2001] *)
+(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *)
+(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *)
+(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *)
 (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
 
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+
+open Pp
+open Util
+
 (* Universes are stratified by a partial ordering $\le$.
    Let $\~{}$ be the associated equivalence. We also have a strict ordering
    $<$ between equivalence classes, and we maintain that $<$ is acyclic,
@@ -24,11 +28,40 @@
    union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
-open Pp
-open Util
+module UniverseLevel = struct
+
+  type t =
+    | Set
+    | Level of Names.dir_path * int
+
+  (* A specialized comparison function: we compare the [int] part
+     first (this property is used by the [check_sorted] function
+     below). This way, most of the time, the [dir_path] part is not
+     considered. *)
+
+  let compare u v = match u,v with
+    | Set, Set -> 0
+    | Set, _ -> -1
+    | _, Set -> 1
+    | Level (dp1, i1), Level (dp2, i2) ->
+      if i1 < i2 then -1
+      else if i1 > i2 then 1
+      else compare dp1 dp2
+
+  let to_string = function
+    | Set -> "Set"
+    | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+end
+
+module UniverseLMap = Map.Make (UniverseLevel)
+module UniverseLSet = Set.Make (UniverseLevel)
+
+type universe_level = UniverseLevel.t
+
+let compare_levels = UniverseLevel.compare
 
 (* An algebraic universe [universe] is either a universe variable
-   [universe_level] or a formal universe known to be greater than some
+   [UniverseLevel.t] or a formal universe known to be greater than some
    universe variables and strictly greater than some (other) universe
    variables
 
@@ -37,38 +70,21 @@ open Util
    universes inferred while type-checking: it is either the successor
    of a universe present in the initial term to type-check or the
    maximum of two algebraic universes
- *)
-
-type universe_level =
-  | Set
-  | Level of Names.dir_path * int
-
-(* A specialized comparison function: we compare the [int] part first.
-   This way, most of the time, the [dir_path] part is not considered. *)
-
-let cmp_univ_level u v = match u,v with
-  | Set, Set -> 0
-  | Set, _ -> -1
-  | _, Set -> 1
-  | Level (dp1,i1), Level (dp2,i2) ->
-      if i1 < i2 then -1
-      else if i1 > i2 then 1
-      else compare dp1 dp2
-
-let string_of_univ_level = function
-  | Set -> "Set"
-  | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
-
-module UniverseLMap =
- Map.Make (struct type t = universe_level let compare = cmp_univ_level end)
+*)
 
 type universe =
-  | Atom of universe_level
-  | Max of universe_level list * universe_level list
+  | Atom of UniverseLevel.t
+  | Max of UniverseLevel.t list * UniverseLevel.t list
+
+let make_universe_level (m,n) = UniverseLevel.Level (m,n)
+let make_universe l = Atom l
+let make_univ c = Atom (make_universe_level c)
 
-let make_univ (m,n) = Atom (Level (m,n))
+let universe_level = function
+  | Atom l -> Some l
+  | Max _ -> None
 
-let pr_uni_level u = str (string_of_univ_level u)
+let pr_uni_level u = str (UniverseLevel.to_string u)
 
 let pr_uni = function
   | Atom u ->
@@ -97,7 +113,7 @@ let super = function
 let sup u v =
   match u,v with
     | Atom u, Atom v ->
-	if cmp_univ_level u v = 0 then Atom u else Max ([u;v],[])
+	if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[])
     | u, Max ([],[]) -> u
     | Max ([],[]), v -> v
     | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
@@ -109,16 +125,16 @@ let sup u v =
 
 (* Comparison on this type is pointer equality *)
 type canonical_arc =
-    { univ: universe_level; lt: universe_level list; le: universe_level list }
+    { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list }
 
 let terminal u = {univ=u; lt=[]; le=[]}
 
-(* A universe_level is either an alias for another one, or a canonical one,
+(* A UniverseLevel.t is either an alias for another one, or a canonical one,
    for which we know the universes that are above *)
 
 type univ_entry =
     Canonical of canonical_arc
-  | Equiv of universe_level
+  | Equiv of UniverseLevel.t
 
 
 type universes = univ_entry UniverseLMap.t
@@ -129,12 +145,6 @@ let enter_equiv_arc u v g =
 let enter_arc ca g =
   UniverseLMap.add ca.univ (Canonical ca) g
 
-let declare_univ u g =
-  if not (UniverseLMap.mem u g) then
-    enter_arc (terminal u) g
-  else
-    g
-
 (* The lower predicative level of the hierarchy that contains (impredicative)
    Prop and singleton inductive types *)
 let type0m_univ = Max ([],[])
@@ -144,28 +154,30 @@ let is_type0m_univ = function
   | _ -> false
 
 (* The level of predicative Set *)
-let type0_univ = Atom Set
+let type0_univ = Atom UniverseLevel.Set
 
 let is_type0_univ = function
-  | Atom Set -> true
-  | Max ([Set],[]) -> warning "Non canonical Set"; true
+  | Atom UniverseLevel.Set -> true
+  | Max ([UniverseLevel.Set], []) -> warning "Non canonical Set"; true
   | u -> false
 
 let is_univ_variable = function
-  | Atom a when a<>Set -> true
+  | Atom a when a<>UniverseLevel.Set -> true
   | _ -> false
 
 (* When typing [Prop] and [Set], there is no constraint on the level,
    hence the definition of [type1_univ], the type of [Prop] *)
 
-let type1_univ = Max ([],[Set])
+let type1_univ = Max ([], [UniverseLevel.Set])
 
 let initial_universes = UniverseLMap.empty
+let is_initial_universes = UniverseLMap.is_empty
 
-(* Every universe_level has a unique canonical arc representative *)
+(* Every UniverseLevel.t has a unique canonical arc representative *)
 
-(* repr : universes -> universe_level -> canonical_arc *)
+(* repr : universes -> UniverseLevel.t -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
+
 let repr g u =
   let rec repr_rec u =
     let a =
@@ -181,6 +193,20 @@ let repr g u =
 
 let can g = List.map (repr g)
 
+(* [safe_repr] also search for the canonical representative, but
+   if the graph doesn't contain the searched universe, we add it. *)
+
+let safe_repr g u =
+  let rec safe_repr_rec u =
+    match UniverseLMap.find u g with
+      | Equiv v -> safe_repr_rec v
+      | Canonical arc -> arc
+  in
+  try g, safe_repr_rec u
+  with Not_found ->
+    let can = terminal u in
+    enter_arc can g, can
+
 (* reprleq : canonical_arc -> canonical_arc list *)
 (* All canonical arcv such that arcu<=arcv with arcv#arcu *)
 let reprleq g arcu =
@@ -196,11 +222,11 @@ let reprleq g arcu =
   searchrec [] arcu.le
 
 
-(* between : universe_level -> canonical_arc -> canonical_arc list *)
+(* between : UniverseLevel.t -> 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 =
+let between g arcu arcv =
   (* good are all w | u <= w <= v  *)
   (* bad are all w | u <= w ~<= v *)
     (* find good and bad nodes in {w | u <= w} *)
@@ -221,7 +247,7 @@ let between g u arcv =
 	else
 	  good, arcu::bad, b    (* b or false *)
   in
-  let good,_,_ = explore ([arcv],[],false) (repr g u) in
+  let good,_,_ = explore ([arcv],[],false) arcu in
     good
 
 (* We assume  compare(u,v) = LE with v canonical (see compare below).
@@ -272,9 +298,7 @@ let compare_neq g arcu arcv =
   in
   cmp [] [] ([],[arcu])
 
-let compare g u v =
-  let arcu = repr g u
-  and arcv = repr g v in
+let compare g arcu arcv =
   if arcu == arcv then EQ else compare_neq g arcu arcv
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
@@ -286,11 +310,12 @@ let compare g u v =
    Adding u>v is consistent iff compare(v,u) = NLE
     and then it is redundant iff compare(u,v) = LT *)
 
-let compare_eq g u v =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  repr g u == repr g v
+(** * Universe checks [check_eq] and [check_geq], used in coqchk *)
 
+let compare_eq g u v =
+  let g, arcu = safe_repr g u in
+  let _, arcv = safe_repr g v in
+  arcu == arcv
 
 type check_function = universes -> universe -> universe -> bool
 
@@ -310,10 +335,10 @@ let rec check_eq g u v =
     | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
 
 let compare_greater g strict u v =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  if not strict && compare_eq g v Set then true else
-  match compare g v u with
+  let g, arcu = safe_repr g u in
+  let g, arcv = safe_repr g v in
+  if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else
+  match compare g arcv arcu with
     | (EQ|LE) -> not strict
     | LT -> true
     | NLE -> false
@@ -323,44 +348,50 @@ let compare_greater g strict u v =
   ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
   b
 *)
-let rec check_greater g strict u v =
+let check_geq g u v =
   match u, v with
-    | Atom ul, Atom vl -> compare_greater g strict ul vl
+    | Atom ul, Atom vl -> compare_greater g false ul vl
     | Atom ul, Max(le,lt) ->
-        List.for_all (fun vl -> compare_greater g strict ul vl) le &&
+        List.for_all (fun vl -> compare_greater g false ul vl) le &&
         List.for_all (fun vl -> compare_greater g true ul vl) lt
     | _ -> anomaly "check_greater"
 
-let check_geq g = check_greater g false
+(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
 
-(* setlt : universe_level -> universe_level -> unit *)
+(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* forces u > v *)
-let setlt g u v =
-  let arcu = repr g u in
-  enter_arc {arcu with lt=v::arcu.lt} g
+(* this is normally an update of u in g rather than a creation. *)
+let setlt g arcu arcv =
+  let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
+  enter_arc arcu' g, arcu'
 
 (* checks that non-redundant *)
-let setlt_if g u v = match compare g u v with
-  | LT -> g
-  | _ -> setlt g u v
+let setlt_if (g,arcu) v =
+  let arcv = repr g v in
+  match compare g arcu arcv with
+  | LT -> g, arcu
+  | _ -> setlt g arcu arcv
 
-(* setleq : universe_level -> universe_level -> unit *)
+(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* forces u >= v *)
-let setleq g u v =
-  let arcu = repr g u in
-  enter_arc {arcu with le=v::arcu.le} g
+(* this is normally an update of u in g rather than a creation. *)
+let setleq g arcu arcv =
+  let arcu' = {arcu with le=arcv.univ::arcu.le} in
+  enter_arc arcu' g, arcu'
 
 
 (* checks that non-redundant *)
-let setleq_if g u v = match compare g u v with
-  | NLE -> setleq g u v
-  | _ -> g
+let setleq_if (g,arcu) v =
+  let arcv = repr g v in
+  match compare g arcu arcv with
+  | NLE -> setleq g arcu arcv
+  | _ -> g, arcu
 
-(* merge : universe_level -> universe_level -> unit *)
+(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* we assume  compare(u,v) = LE *)
 (* 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
+let merge g arcu arcv =
+  match between g arcu arcv with
     | arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
                  (* redirected to it *)
 	let redirect (g,w,w') arcv =
@@ -368,87 +399,84 @@ let merge g u v =
  	  (g',list_unionq arcv.lt w,arcv.le@w')
 	in
 	let (g',w,w') = List.fold_left redirect (g,[],[]) v in
-	let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in
-	let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in
-	g'''
+	let g_arcu = (g',arcu) in
+	let g_arcu = List.fold_left setlt_if g_arcu w in
+	let g_arcu = List.fold_left setleq_if g_arcu w' in
+	fst g_arcu
     | [] -> anomaly "Univ.between"
 
-(* merge_disc : universe_level -> universe_level -> unit *)
+(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* we assume  compare(u,v) = compare(v,u) = NLE *)
 (* 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 merge_disc g arcu arcv =
   let g' = enter_equiv_arc arcv.univ arcu.univ g in
-  let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in
-  let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in
-  g'''
+  let g_arcu = (g',arcu) in
+  let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
+  let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
+  fst g_arcu
 
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
 
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
 
 let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v))
 
-(* enforce_univ_leq : universe_level -> universe_level -> unit *)
+(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
 let enforce_univ_leq u v g =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  match compare g u v with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | NLE ->
-	(match compare g v u with
+	(match compare g arcv arcu with
            | LT -> error_inconsistency Le u v
-           | LE -> merge g v u
-           | NLE -> setleq g u v
+           | LE -> merge g arcv arcu
+           | NLE -> fst (setleq g arcu arcv)
            | EQ -> anomaly "Univ.compare")
     | _ -> g
 
-(* enforc_univ_eq : universe_level -> universe_level -> unit *)
+(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* enforc_univ_eq 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
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | EQ -> g
     | LT -> error_inconsistency Eq u v
-    | LE -> merge g u v
+    | LE -> merge g arcu arcv
     | NLE ->
-	(match compare g v u with
+	(match compare g arcv arcu with
            | LT -> error_inconsistency Eq u v
-           | LE -> merge g v u
-           | NLE -> merge_disc g u v
+           | LE -> merge g arcv arcu
+           | NLE -> merge_disc g arcu arcv
            | EQ -> anomaly "Univ.compare")
 
 (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
 let enforce_univ_lt u v g =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  match compare g u v with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | LT -> g
-    | LE -> setlt g u v
+    | LE -> fst (setlt g arcu arcv)
     | EQ -> error_inconsistency Lt u v
     | NLE ->
-	(match compare g v u with
-           | NLE -> setlt g u v
+	(match compare g arcv arcu with
+           | NLE -> fst (setlt g arcu arcv)
            | _ -> error_inconsistency Lt u v)
 
 (* Constraints and sets of consrtaints. *)
 
-type constraint_type = Lt | Leq | Eq
-
-type univ_constraint = universe_level * constraint_type * universe_level
+type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t
 
 let enforce_constraint cst g =
   match cst with
     | (u,Lt,v) -> enforce_univ_lt u v g
-    | (u,Leq,v) -> enforce_univ_leq u v g
+    | (u,Le,v) -> enforce_univ_leq u v g
     | (u,Eq,v) -> enforce_univ_eq u v g
 
-
 module Constraint = Set.Make(
   struct
     type t = univ_constraint
@@ -457,11 +485,16 @@ module Constraint = Set.Make(
 
 type constraints = Constraint.t
 
+let empty_constraint = Constraint.empty
+let is_empty_constraint = Constraint.is_empty
+
+let union_constraints = Constraint.union
+
 type constraint_function =
     universe -> universe -> constraints -> constraints
 
 let constraint_add_leq v u c =
-  if v = Set then c else Constraint.add (v,Leq,u) c
+  if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c
 
 let enforce_geq u v c =
   match u, v with
@@ -479,13 +512,207 @@ let enforce_eq u v c =
 let merge_constraints c g =
   Constraint.fold enforce_constraint c g
 
+(* Normalization *)
+
+let lookup_level u g =
+  try Some (UniverseLMap.find u g) with Not_found -> None
+
+(** [normalize_universes g] returns a graph where all edges point
+    directly to the canonical representent of their target. The output
+    graph should be equivalent to the input graph from a logical point
+    of view, but optimized. We maintain the invariant that the key of
+    a [Canonical] element is its own name, by keeping [Equiv] edges
+    (see the assertion)... I (Stéphane Glondu) am not sure if this
+    plays a role in the rest of the module. *)
+let normalize_universes g =
+  let rec visit u arc cache = match lookup_level u cache with
+    | Some x -> x, cache
+    | None -> match Lazy.force arc with
+    | None ->
+      u, UniverseLMap.add u u cache
+    | Some (Canonical {univ=v; lt=_; le=_}) ->
+      v, UniverseLMap.add u v cache
+    | Some (Equiv v) ->
+      let v, cache = visit v (lazy (lookup_level v g)) cache in
+      v, UniverseLMap.add u v cache
+  in
+  let cache = UniverseLMap.fold
+    (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
+    g UniverseLMap.empty
+  in
+  let repr x = UniverseLMap.find x cache in
+  let lrepr us = List.fold_left
+    (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us
+  in
+  let canonicalize u = function
+    | Equiv _ -> Equiv (repr u)
+    | Canonical {univ=v; lt=lt; le=le} ->
+      assert (u == v);
+      (* avoid duplicates and self-loops *)
+      let lt = lrepr lt and le = lrepr le in
+      let le = UniverseLSet.filter
+        (fun x -> x != u && not (UniverseLSet.mem x lt)) le
+      in
+      UniverseLSet.iter (fun x -> assert (x != u)) lt;
+      Canonical {
+        univ = v;
+        lt = UniverseLSet.elements lt;
+        le = UniverseLSet.elements le;
+      }
+  in
+  UniverseLMap.mapi canonicalize g
+
+(** [check_sorted g sorted]: [g] being a universe graph, [sorted]
+    being a map to levels, checks that all constraints in [g] are
+    satisfied in [sorted]. *)
+let check_sorted g sorted =
+  let get u = try UniverseLMap.find u sorted with
+    | Not_found -> assert false
+  in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with
+    | Equiv v -> assert (lu = get v)
+    | Canonical {univ=u'; lt=lt; le=le} ->
+      assert (u == u');
+      List.iter (fun v -> assert (lu <= get v)) le;
+      List.iter (fun v -> assert (lu < get v)) lt) g
+
+(**
+  Bellman-Ford algorithm with a few customizations:
+    - [weight(eq|le) = 0], [weight(lt) = -1]
+    - a [le] edge is initially added from [bottom] to all other
+      vertices, and [bottom] is used as the source vertex
+*)
+let bellman_ford bottom g =
+  assert (lookup_level bottom g = None);
+  let ( << ) a b = match a, b with
+    | _, None -> true
+    | None, _ -> false
+    | Some x, Some y -> x < y
+  and ( ++ ) a y = match a with
+    | None -> None
+    | Some x -> Some (x-y)
+  and push u x m = match x with
+    | None -> m
+    | Some y -> UniverseLMap.add u y m
+  in
+  let relax u v uv distances =
+    let x = lookup_level u distances ++ uv in
+    if x << lookup_level v distances then push v x distances
+    else distances
+  in
+  let init = UniverseLMap.add bottom 0 UniverseLMap.empty in
+  let vertices = UniverseLMap.fold (fun u arc res ->
+    let res = UniverseLSet.add u res in
+    match arc with
+      | Equiv e -> UniverseLSet.add e res
+      | Canonical {univ=univ; lt=lt; le=le} ->
+        assert (u == univ);
+        let add res v = UniverseLSet.add v res in
+        let res = List.fold_left add res le in
+        let res = List.fold_left add res lt in
+        res) g UniverseLSet.empty
+  in
+  let g =
+    let node = Canonical {
+      univ = bottom;
+      lt = [];
+      le = UniverseLSet.elements vertices
+    } in UniverseLMap.add bottom node g
+  in
+  let rec iter count accu =
+    if count <= 0 then
+      accu
+    else
+      let accu = UniverseLMap.fold (fun u arc res -> match arc with
+        | Equiv e -> relax e u 0 (relax u e 0 res)
+        | Canonical {univ=univ; lt=lt; le=le} ->
+          assert (u == univ);
+          let res = List.fold_left (fun res v -> relax u v 0 res) res le in
+          let res = List.fold_left (fun res v -> relax u v 1 res) res lt in
+          res) g accu
+      in iter (count-1) accu
+  in
+  let distances = iter (UniverseLSet.cardinal vertices) init in
+  let () = UniverseLMap.iter (fun u arc ->
+    let lu = lookup_level u distances in match arc with
+      | Equiv v ->
+        let lv = lookup_level v distances in
+        assert (not (lu << lv) && not (lv << lu))
+      | Canonical {univ=univ; lt=lt; le=le} ->
+        assert (u == univ);
+        List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le;
+        List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g
+  in distances
+
+(** [sort_universes g] builds a map from universes in [g] to natural
+    numbers. It outputs a graph containing equivalence edges from each
+    level appearing in [g] to [Type.n], and [lt] edges between the
+    [Type.n]s. The output graph should imply the input graph (and the
+    implication will be strict most of the time), but is not
+    necessarily minimal. Note: the result is unspecified if the input
+    graph already contains [Type.n] nodes (calling a module Type is
+    probably a bad idea anyway). *)
+let sort_universes orig =
+  let mp = Names.make_dirpath [Names.id_of_string "Type"] in
+  let rec make_level accu g i =
+    let type0 = UniverseLevel.Level (mp, i) in
+    let distances = bellman_ford type0 g in
+    let accu, continue = UniverseLMap.fold (fun u x (accu, continue) ->
+      let continue = continue || x < 0 in
+      let accu =
+        if x = 0 && u != type0 then UniverseLMap.add u i accu
+        else accu
+      in accu, continue) distances (accu, false)
+    in
+    let filter x = not (UniverseLMap.mem x accu) in
+    let push g u =
+      if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g
+    in
+    let g = UniverseLMap.fold (fun u arc res -> match arc with
+      | Equiv v as x ->
+        begin match filter u, filter v with
+          | true, true -> UniverseLMap.add u x res
+          | true, false -> push res u
+          | false, true -> push res v
+          | false, false -> res
+        end
+      | Canonical {univ=v; lt=lt; le=le} ->
+        assert (u == v);
+        if filter u then
+          let lt = List.filter filter lt in
+          let le = List.filter filter le in
+          UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res
+        else
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
+          res) g UniverseLMap.empty
+    in
+    if continue then make_level accu g (i+1) else i, accu
+  in
+  let max, levels = make_level UniverseLMap.empty orig 0 in
+  (* defensively check that the result makes sense *)
+  check_sorted orig levels;
+  let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
+  let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
+  let g =
+    let rec aux i g =
+      if i < max then
+        let u = types.(i) in
+        let g = UniverseLMap.add u (Canonical {
+          univ = u;
+          le = [];
+          lt = [types.(i+1)]
+        }) g in aux (i+1) g
+      else g
+    in aux 0 g
+  in g
+
 (**********************************************************************)
 (* Tools for sort-polymorphic inductive types                         *)
 
 (* Temporary inductive type levels *)
 
 let fresh_level =
-  let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n)
+  let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n)
 
 let fresh_local_univ () = Atom (fresh_level ())
 
@@ -559,16 +786,6 @@ let no_upper_constraints u cst =
 
 (* Pretty-printing *)
 
-let num_universes g =
-  UniverseLMap.fold (fun _ _ -> succ) g 0
-
-let num_edges g =
-  let reln_len = function
-    | Equiv _ -> 1
-    | Canonical {lt=lt;le=le} -> List.length lt + List.length le
-  in
-  UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0
-
 let pr_arc = function
   | _, Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
@@ -590,7 +807,7 @@ let pr_constraints c =
   Constraint.fold (fun (u1,op,u2) pp_std ->
 		     let op_str = match op with
 		       | Lt -> " < "
-		       | Leq -> " <= "
+		       | Le -> " <= "
 		       | Eq -> " = "
 		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
 			  pr_uni_level u2 ++ fnl () )  c (str "")
@@ -600,37 +817,40 @@ let pr_constraints c =
 let dump_universes output g =
   let dump_arc u = function
     | Canonical {univ=u; lt=lt; le=le} ->
-	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))
-	    lt;
-	  List.iter
-	    (fun v ->
-	       Printf.fprintf output "%s <= %s ;\n" u_str
-		 (string_of_univ_level v))
-	    le
+	let u_str = UniverseLevel.to_string u in
+	List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt;
+	List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le
     | Equiv v ->
-	Printf.fprintf output "%s = %s ;\n"
-	  (string_of_univ_level u) (string_of_univ_level v)
+      output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v)
   in
     UniverseLMap.iter dump_arc g
 
 (* Hash-consing *)
 
+module Hunivlevel =
+  Hashcons.Make(
+    struct
+      type t = universe_level
+      type u = Names.dir_path -> Names.dir_path
+      let hash_sub hdir = function
+	| UniverseLevel.Set -> UniverseLevel.Set
+	| UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n)
+      let equal l1 l2 = match l1,l2 with
+	| UniverseLevel.Set, UniverseLevel.Set -> true
+	| UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') ->
+	  n == n' && d == d'
+	| _ -> false
+      let hash = Hashtbl.hash
+    end)
+
 module Huniv =
   Hashcons.Make(
     struct
       type t = universe
-      type u = Names.dir_path -> Names.dir_path
-      let hash_aux hdir = function
-	| Set -> Set
-	| Level (d,n) -> Level (hdir d,n)
+      type u = universe_level -> universe_level
       let hash_sub hdir = function
-	| Atom u -> Atom (hash_aux hdir u)
-	| Max (gel,gtl) ->
-	    Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
+	| Atom u -> Atom (hdir u)
+	| Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl)
       let equal u v =
 	match u, v with
 	  | Atom u, Atom v -> u == v
@@ -641,7 +861,33 @@ module Huniv =
       let hash = Hashtbl.hash
     end)
 
-let hcons1_univ u =
-  let _,_,hdir,_,_,_ = Names.hcons_names() in
-  Hashcons.simple_hcons Huniv.f hdir u
+let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath
+let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel
+
+module Hconstraint =
+  Hashcons.Make(
+    struct
+      type t = univ_constraint
+      type u = universe_level -> universe_level
+      let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2)
+      let equal (l1,k,l2) (l1',k',l2') =
+	l1 == l1' && k = k' && l2 == l2'
+      let hash = Hashtbl.hash
+    end)
+
+module Hconstraints =
+  Hashcons.Make(
+    struct
+      type t = constraints
+      type u = univ_constraint -> univ_constraint
+      let hash_sub huc s =
+	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
+      let equal s s' =
+	list_for_all2eq (==)
+	  (Constraint.elements s)
+	  (Constraint.elements s')
+      let hash = Hashtbl.hash
+    end)
 
+let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel
+let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 4cb6dec1..8b3f6291 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -1,37 +1,43 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Universes. *)
+(** Universes. *)
 
+type universe_level
 type universe
 
-(* The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... *)
-(* Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+module UniverseLSet : Set.S with type elt = universe_level
+
+(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... 
+   Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
 
-val type0m_univ : universe  (* image of Prop in the universes hierarchy *)
-val type0_univ : universe  (* image of Set in the universes hierarchy *)
-val type1_univ : universe  (* the universe of the type of Prop/Set *)
+val type0m_univ : universe  (** image of Prop in the universes hierarchy *)
+val type0_univ : universe  (** image of Set in the universes hierarchy *)
+val type1_univ : universe  (** the universe of the type of Prop/Set *)
 
+val make_universe_level : Names.dir_path * int -> universe_level
+val make_universe : universe_level -> universe
 val make_univ : Names.dir_path * int -> universe
 
 val is_type0_univ : universe -> bool
 val is_type0m_univ : universe -> bool
 val is_univ_variable : universe -> bool
 
-(* The type of a universe *)
+val universe_level : universe -> universe_level option
+val compare_levels : universe_level -> universe_level -> int
+
+(** The type of a universe *)
 val super : universe -> universe
 
-(* The max of 2 universes *)
+(** The max of 2 universes *)
 val sup   : universe -> universe -> universe
 
-(*s Graphs of universes. *)
+(** {6 Graphs of universes. } *)
 
 type universes
 
@@ -39,32 +45,39 @@ type check_function = universes -> universe -> universe -> bool
 val check_geq : check_function
 val check_eq : check_function
 
-(* The empty graph of universes *)
+(** The empty graph of universes *)
 val initial_universes : universes
+val is_initial_universes : universes -> bool
 
-(*s Constraints. *)
+(** {6 Constraints. } *)
 
-module Constraint : Set.S
+type constraints
 
-type constraints = Constraint.t
+val empty_constraint : constraints
+val union_constraints : constraints -> constraints -> constraints
+
+val is_empty_constraint : constraints -> bool
 
 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.
+(** {6 ... } *)
+(** 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. *)
 
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
 
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
 
 val merge_constraints : constraints -> universes -> universes
+val normalize_universes : universes -> universes
+val sort_universes : universes -> universes
 
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
 
 val fresh_local_univ : unit -> universe
 
@@ -78,14 +91,21 @@ val subst_large_constraints :
 
 val no_upper_constraints : universe -> constraints -> bool
 
-(*s Pretty-printing of universes. *)
+(** {6 Pretty-printing of universes. } *)
 
+val pr_uni_level : universe_level -> Pp.std_ppcmds
 val pr_uni : universe -> Pp.std_ppcmds
 val pr_universes : universes -> Pp.std_ppcmds
 val pr_constraints : constraints -> Pp.std_ppcmds
 
-(*s Dumping to a file *)
+(** {6 Dumping to a file } *)
+
+val dump_universes :
+  (constraint_type -> string -> string -> unit) ->
+  universes -> unit
 
-val dump_universes : out_channel -> universes -> unit
+(** {6 Hash-consing } *)
 
-val hcons1_univ : universe -> universe
+val hcons_univlevel : universe_level -> universe_level
+val hcons_univ : universe -> universe
+val hcons_constraints : constraints -> constraints
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index a35d1d88..4d0edc68 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -74,6 +74,8 @@ and conv_whd pb k whd1 whd2 cu =
       else raise NotConvertible
   | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
       conv_atom pb k a1 stk1 a2 stk2 cu
+  | Vfun _, _ | _, Vfun _ ->
+      conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
   | _, Vatom_stk(Aiddef(_,v),stk) ->
       conv_whd pb k whd1 (force_whd v stk) cu
   | Vatom_stk(Aiddef(_,v),stk), _ ->
@@ -98,7 +100,7 @@ and conv_atom pb k a1 stk1 a2 stk2 cu =
 	    conv_stack k stk1 stk2 cu
 	  else raise NotConvertible
 	with NotConvertible ->
-	  if oracle_order ik1 ik2 then
+	  if oracle_order false ik1 ik2 then
             conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
           else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
       end
@@ -219,12 +221,12 @@ and conv_eq_vect vt1 vt2 cu =
 
 let vconv pb env t1 t2 =
   let cu =
-    try conv_eq pb t1 t2 Constraint.empty
+    try conv_eq pb t1 t2 empty_constraint
     with NotConvertible ->
       infos := create_clos_infos betaiotazeta env;
       let v1 = val_of_constr env t1 in
       let v2 = val_of_constr env t2 in
-      let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
+      let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in
       cu
   in cu
 
@@ -234,8 +236,8 @@ let use_vm = ref false
 
 let set_use_vm b =
   use_vm := b;
-  if b then Reduction.set_default_conv vconv
-  else Reduction.set_default_conv Reduction.conv_cmp
+  if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb)
+  else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb)
 
 let use_vm _ = !use_vm
 
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index e23aaf79..2d65170c 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
 open Names
 open Term
 open Environ
 open Reduction
-(*i*)
 
-(***********************************************************************)
-(*s conversion functions *)
+(**********************************************************************
+  s conversion functions *)
 val use_vm : unit -> bool
 val set_use_vm : bool -> unit
 val vconv : conv_pb -> types conversion_function
diff --git a/kernel/vm.ml b/kernel/vm.ml
index c24de162..86aed5d9 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vm.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Conv_oracle
@@ -462,7 +460,7 @@ let current_cofix vcf =
       else find_cofix (pos+1)
     else raise Not_found in
   try find_cofix 0
-  with _ -> assert false
+  with Not_found -> assert false
 
 let check_cofix vcf1 vcf2 =
   (current_cofix vcf1 = current_cofix vcf2) &&
@@ -538,13 +536,8 @@ let branch_of_switch k sw =
   Array.map eval_branch sw.sw_annot.rtbl
 
 
-(* Evaluation *)
-
 
-let is_accu v =
-  let o = Obj.repr v in
-  Obj.is_block o && Obj.tag o = accu_tag &&
-  fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag
+(* Evaluation *)
 
 let rec whd_stack v stk =
   match stk with
@@ -594,6 +587,55 @@ let rec force_whd v stk =
   | res -> res
 
 
+let rec eta_stack a stk v =
+  match stk with
+  | [] -> apply_vstack a [|v|]
+  | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v
+  | Zfix(f,args) :: stk ->
+      let a,stk = 
+	match stk with
+	| Zapp args' :: stk ->
+	    push_ra stop;
+	    push_arguments args';
+	    push_val a;
+	    push_arguments args;
+	    let a =
+	      interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+		(nargs args+ nargs args') in
+	    a, stk
+	| _ -> 
+	    push_ra stop;
+	    push_val a;
+	    push_arguments args;
+	    let a =
+	      interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+		(nargs args) in
+	    a, stk in
+      eta_stack a stk v
+  | Zswitch sw :: stk ->
+      eta_stack (apply_switch sw a) stk v
+
+let eta_whd k whd =
+  let v = val_of_rel k in
+  match whd with
+  | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false
+  | Vfun f -> body_of_vfun k f
+  | Vfix(f, None) -> 
+      push_ra stop;
+      push_val v;
+      interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0
+  | Vfix(f, Some args) ->
+      push_ra stop;
+      push_val v;
+      push_arguments args;
+      interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) 
+  | Vcofix(_,to_up,_) ->
+      push_ra stop;
+      push_val v;
+      interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0
+  | Vatom_stk(a,stk) ->
+      eta_stack (val_of_atom a) stk v 
 
 
-
+      
+      
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 5ecc8d99..58228eb8 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -3,15 +3,18 @@ open Term
 open Cbytecodes
 open Cemitcodes
 
+(** Efficient Virtual Machine *)
 
 val set_drawinstr : unit -> unit
 
 val transp_values : unit -> bool
 val set_transp_values : bool -> unit
-(* le code machine *)
+
+(** Machine code *)
+
 type tcode
 
-(* Les valeurs ***********)
+(** Values *)
 
 type vprod
 type vfun
@@ -26,11 +29,11 @@ type atom =
   | Aiddef of id_key * values
   | Aind of inductive
 
-(* Les zippers *)
+(** Zippers *)
 
 type zipper =
   | Zapp of arguments
-  | Zfix of vfix*arguments  (* Peut-etre vide *)
+  | Zfix of vfix * arguments  (** might be empty *)
   | Zswitch of vswitch
 
 type stack = zipper list
@@ -48,6 +51,7 @@ type whd =
   | Vatom_stk of atom * stack
 
 (** Constructors *)
+
 val val_of_str_const : structured_constant -> values
 
 val val_of_rel : int -> values
@@ -62,45 +66,56 @@ val val_of_constant_def : int -> constant -> values -> values
 external val_of_annot_switch : annot_switch -> values = "%identity"
 
 (** Destructors *)
+
 val whd_val : values -> whd
 
-(* Arguments *)
+(** Arguments *)
+
 val nargs : arguments -> int
 val arg : arguments -> int -> values
 
-(* Product *)
+(** Product *)
+
 val dom : vprod -> values
 val codom : vprod -> vfun
 
-(* Function *)
+(** Function *)
+
 val body_of_vfun : int -> vfun -> values
 val decompose_vfun2  : int -> vfun -> vfun -> int * values * values
 
-(* Fix *)
+(** Fix *)
+
 val current_fix : vfix -> int
 val check_fix : vfix -> vfix -> bool
 val rec_args : vfix -> int array
 val reduce_fix : int -> vfix -> vfun array * values array
-                              (* bodies ,  types *)
+                              (** bodies ,  types *)
+
+(** CoFix *)
 
-(* CoFix *)
 val current_cofix : vcofix -> int
 val check_cofix : vcofix -> vcofix -> bool
 val reduce_cofix : int -> vcofix -> values array * values array
-                                      (* bodies , types *)
-(* Block *)
+                                      (** bodies , types *)
+
+(** Block *)
+
 val btag : vblock -> int
 val bsize : vblock -> int
 val bfield : vblock -> int -> values
 
-(* Switch *)
+(** Switch *)
+
 val check_switch : vswitch -> vswitch -> bool
 val case_info : vswitch -> case_info
 val type_of_switch : vswitch -> values
 val branch_of_switch : int -> vswitch -> (int * values) array
 
-(* Evaluation *)
+(** Evaluation *)
+
 val whd_stack : values -> stack -> whd
 val force_whd : values -> stack -> whd
 
+val eta_whd : int -> whd -> values