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

58 files changed, 4272 insertions, 1724 deletions

diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
index affcccb3..55b907ad 100644
--- a/kernel/byterun/coq_fix_code.c
+++ b/kernel/byterun/coq_fix_code.c
@@ -8,6 +8,9 @@
 /*                                                                     */
 /***********************************************************************/
 
+/* Arnaud Spiwack: expanded the virtual machine with operators used
+   for fast computation of bounded (31bits) integers */
+
 #include <stdio.h>
 #include <stdlib.h> 
 #include <config.h>
@@ -37,7 +40,13 @@ void init_arity () {
     arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]=
     arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]=
     arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]=
-    arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= 0;
+    arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= 
+    arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]=
+    arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]=
+    arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]=
+    arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]=
+    arity[HEAD0INT31]=arity[TAIL0INT31]=
+    arity[COMPINT31]=arity[DECOMPINT31]=0;
   /* instruction with one operand */
   arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]=
     arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=
@@ -45,9 +54,11 @@ void init_arity () {
     arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]=
     arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]=
     arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=
-    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]= 1;
+    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]=
+    arity[BRANCH]=arity[ISCONST]= 1;
   /* instruction with two operands */
-  arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=2;
+  arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=
+  arity[ARECONST]=2;
   /* instruction with four operands */ 
   arity[MAKESWITCHBLOCK]=4;
   /* instruction with arbitrary operands */
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
index d1dac80f..00345318 100644
--- a/kernel/byterun/coq_fix_code.h
+++ b/kernel/byterun/coq_fix_code.h
@@ -31,4 +31,5 @@ value coq_makeaccu (value i);
 value coq_pushpop (value i);
 value coq_accucond (value i);
 value coq_is_accumulate_code(value code);
+
 #endif /* _COQ_FIX_CODE_ */
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
index 89616c5f..8a45e973 100644
--- a/kernel/byterun/coq_instruct.h
+++ b/kernel/byterun/coq_instruct.h
@@ -35,7 +35,18 @@ enum instructions {
   CONST0, CONST1, CONST2, CONST3, CONSTINT,
   PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
   ACCUMULATE, ACCUMULATECOND, 
-  MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, STOP
+  MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, 
+/* spiwack: */
+  BRANCH,
+  ADDINT31, ADDCINT31, ADDCARRYCINT31,
+  SUBINT31, SUBCINT31, SUBCARRYCINT31,
+  MULCINT31, MULINT31, DIV21INT31, DIVINT31,
+  ADDMULDIVINT31, COMPAREINT31, 
+  HEAD0INT31, TAIL0INT31,
+  ISCONST, ARECONST,
+  COMPINT31, DECOMPINT31,
+/* /spiwack  */
+  STOP
 };
 
 #endif /* _COQ_INSTRUCT_ */
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index 8f9c10e6..880e978a 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -10,12 +10,31 @@
 
 /* The bytecode interpreter */
 
+/* Spiwack: expanded the virtual machine with operators used
+   for fast computation of bounded (31bits) integers */
+
 #include <stdio.h>
 #include "coq_gc.h"
 #include "coq_instruct.h"
 #include "coq_fix_code.h"
-#include "coq_memory.h"  
-#include "coq_values.h"
+#include "coq_memory.h" 
+#include "coq_values.h" 
+
+/*spiwack : imports support functions for 64-bit integers */
+#include "config.h"
+#ifdef ARCH_INT64_TYPE
+#include "int64_native.h"
+#else
+#include "int64_emul.h"
+#endif
+
+/* spiwack: I append here a few macros for value/number manipulation */
+#define uint32_of_value(val) (((uint32)val >> 1))
+#define value_of_uint32(i)   ((value)(((uint32)(i) << 1) | 1))
+#define UI64_of_uint32(lo)  ((uint64)(I64_literal(0,(uint32)(lo))))
+#define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val)))
+/* /spiwack */
+
 
 
 /* Registers for the abstract machine:
@@ -61,11 +80,11 @@ 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)
+/* 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 */
@@ -1035,7 +1054,326 @@ value coq_interprete
 	sp += 2;
 	Next;
       }
-      
+
+      /* spiwack: code for interpreting compiled integers */
+      Instruct(BRANCH) {
+	/* unconditional branching */
+        print_instr("BRANCH");
+        pc += *pc;
+        /* pc = (code_t)(pc+*pc); */
+        Next;
+      }
+
+      Instruct(ADDINT31) {
+        /* Adds the integer in the accumulator with 
+           the one ontop of the stack (which is poped)*/
+        print_instr("ADDINT31");
+        accu = 
+           (value)((uint32) accu + (uint32) *sp++ - 1); 
+        /* nota,unlike CaML we don't want
+           to have a different behavior depending on the 
+           architecture. Thus we cast the operand to uint32 */
+        Next;
+      }
+
+      Instruct (ADDCINT31) {
+	print_instr("ADDCINT31");
+	/* returns the sum with a carry */
+	uint32 s;
+	s = (uint32)accu + (uint32)*sp++ - 1;
+        if( (uint32)s < (uint32)accu ) {
+          /* carry */
+	  Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */
+	}
+	else {
+	  /*no carry */
+	  Alloc_small(accu, 1, 1);
+	}
+	Field(accu, 0)=(value)s;
+	Next;
+      }
+
+      Instruct (ADDCARRYCINT31) {
+	print_instr("ADDCARRYCINT31");
+	/* returns the sum plus one with a carry */
+	uint32 s;
+	s = (uint32)accu + (uint32)*sp++ + 1;
+	value block;
+        if( (uint32)s <= (uint32)accu ) {
+          /* carry */
+	  Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */
+	}
+	else {
+	  /*no carry */
+	  Alloc_small(accu, 1, 1);
+	}
+	Field(accu, 0)=(value)s;
+	Next;
+      }
+
+      Instruct (SUBINT31) {
+	print_instr("SUBINT31");
+	/* returns the subtraction */
+	accu = 
+	  (value)((uint32) accu - (uint32) *sp++ + 1); 
+        Next;
+      }
+
+      Instruct (SUBCINT31) {
+	print_instr("SUBCINT31");
+	/* returns the subtraction with a carry */
+	uint32 b;
+	uint32 s;
+	b = (uint32)*sp++;
+	s = (uint32)accu - b + 1;
+        if( (uint32)accu < b ) {
+          /* carry */
+	  Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */
+	}
+	else {
+	  /*no carry */
+	  Alloc_small(accu, 1, 1);
+	}
+	Field(accu, 0)=(value)s;
+	Next;
+      }
+
+      Instruct (SUBCARRYCINT31) {
+	print_instr("SUBCARRYCINT31");
+	/* returns the subtraction minus one with a carry */
+	uint32 b;
+	uint32 s;
+	b = (uint32)*sp++;
+	s = (value)((uint32)accu - b - 1);
+        if( (uint32)accu <= b ) {
+          /* carry */
+	  Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */
+	}
+	else {
+	  /*no carry */
+	  Alloc_small(accu, 1, 1);
+	}
+	Field(accu, 0)=(value)s;
+	Next;
+      }
+
+      Instruct (MULINT31) {
+	/* returns the multiplication */
+	print_instr("MULINT31");
+        accu = 
+	  value_of_uint32((uint32_of_value(accu)) * (uint32_of_value(*sp++)));
+	Next;
+      }
+
+      Instruct (MULCINT31) {
+        /*returns the multiplication on a double size word
+          (special case for 0) */
+        print_instr("MULCINT31");
+	uint64 p;
+        /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */
+        p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1));
+	if ( I64_is_zero(p) ) {
+	  accu = (value)1;
+	}
+	else {
+          /* the output type is supposed to have a constant constructor
+	     and a non-constant constructor (in that order), the tag
+	     of the non-constant constructor is then 1 */
+	  Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
+	  /*unsigned shift*/
+	  Field(accu, 0) = (value)(I64_lsr(p,31)|1) ;  /*higher part*/
+	  Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/
+	}
+	Next;
+      }
+
+      Instruct (DIV21INT31) {
+	print_instr("DIV21INT31");
+	/* spiwack: takes three int31 (the two first ones represent an
+                    int62) and performs the euclidian division of the
+                    int62 by the int31 */
+        uint64 bigint;
+        bigint = UI64_of_value(accu);
+        bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++));
+        uint64 divisor;
+        divisor = UI64_of_value(*sp++);
+        Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
+        if (I64_is_zero (divisor)) {
+          Field(accu, 0) = 1; /* 2*0+1 */
+          Field(accu, 1) = 1; /* 2*0+1 */
+	}
+	else {
+	  uint64 quo, mod;
+          I64_udivmod(bigint, divisor, &quo, &mod);
+          Field(accu, 0) = value_of_uint32(I64_to_int32(quo));
+	  Field(accu, 1) = value_of_uint32(I64_to_int32(mod));
+	}
+	Next;
+      }
+
+      Instruct (DIVINT31) {
+	print_instr("DIVINT31");
+        /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag
+                    since it probably only concerns negative number.
+                    needs to be checked at this point */
+        uint32 divisor;
+        divisor = uint32_of_value(*sp++);
+        if (divisor == 0) { 
+          Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
+	  Field(accu, 0) = 1; /* 2*0+1 */
+          Field(accu, 1) = 1; /* 2*0+1 */
+        }
+        else {
+          uint32 modulus;
+          modulus = uint32_of_value(accu);
+          Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */
+	  Field(accu, 0) = value_of_uint32(modulus/divisor);
+          Field(accu, 1) = value_of_uint32(modulus%divisor);
+        }
+	Next;
+      }
+
+      Instruct (ADDMULDIVINT31) {
+        print_instr("ADDMULDIVINT31");
+        /* higher level shift (does shifts and cycles and such) */
+        uint32 shiftby;
+        shiftby = uint32_of_value(accu);
+        if (shiftby > 31) {
+          if (shiftby < 62) {
+            *sp++;
+	    accu = (value)((((*sp++)^1) << (shiftby - 31)) | 1);
+          }
+          else {
+            accu = (value)(1);
+          }
+	}
+        else{
+        /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */
+        accu = (value)(((*sp++)^1) << shiftby);
+        /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */
+        accu = (value)((accu | (((uint32)(*sp++)) >> (31-shiftby)))|1);
+	}
+        Next;
+      }
+
+      Instruct (COMPAREINT31) {
+	/* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */
+	/* assumes Inudctive _ : _ := Eq | Lt | Gt */
+	print_instr("COMPAREINT31");
+	if ((uint32)accu == (uint32)*sp) {
+	  accu = 1;  /* 2*0+1 */
+	  sp++;
+	}
+	else{if ((uint32)accu < (uint32)(*sp++)) {
+	  accu = 3;  /* 2*1+1 */
+	}
+	else{
+	  accu = 5;   /* 2*2+1 */
+	}}
+        Next;
+      }
+ 
+      Instruct (HEAD0INT31) {
+	int r = 0;
+        uint32 x;
+        print_instr("HEAD0INT31");
+	x = (uint32) accu;
+        if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; }
+        if (!(x & 0xFF000000)) { x <<= 8;  r += 8; }
+        if (!(x & 0xF0000000)) { x <<= 4;  r += 4; }
+        if (!(x & 0xC0000000)) { x <<= 2;  r += 2; }
+        if (!(x & 0x80000000)) { x <<=1;   r += 1; }
+        if (!(x & 0x80000000)) {           r += 1; }
+        accu = value_of_uint32(r);
+        Next;
+      }
+        
+      Instruct (TAIL0INT31) {
+	int r = 0;
+        uint32 x;
+        print_instr("TAIL0INT31");
+	x = (((uint32) accu >> 1) | 0x80000000);
+        if (!(x & 0xFFFF)) { x >>= 16; r += 16; }
+        if (!(x & 0x00FF)) { x >>= 8;  r += 8; }
+        if (!(x & 0x000F)) { x >>= 4;  r += 4; }
+        if (!(x & 0x0003)) { x >>= 2;  r += 2; }
+        if (!(x & 0x0001)) { x >>=1;   r += 1; }
+        if (!(x & 0x0001)) {           r += 1; }
+        accu = value_of_uint32(r);
+        Next;
+      }
+
+      Instruct (ISCONST) {
+        /* Branches if the accu does not contain a constant
+           (i.e., a non-block value) */
+        print_instr("ISCONST");
+        if ((accu & 1) == 0) /* last bit is 0 -> it is a block */
+	  pc +=  *pc;
+        else
+	  pc++;
+        Next;
+
+      }
+
+      Instruct (ARECONST) {
+        /* Branches if the n first values on the stack are not
+           all constansts */
+        print_instr("ARECONST");
+        int i, n, ok;
+        ok = 1;
+        n = *pc++;
+        for(i=0; i < n; i++) {
+          if ((sp[i] & 1) == 0) {
+	    ok = 0;
+            break;
+          }
+        }
+        if(ok) pc++; else pc += *pc;
+        Next;
+      }
+
+      Instruct (COMPINT31) {
+        /* makes an 31-bit integer out of the accumulator and
+           the 30 first values of the stack 
+           and put it in the accumulator (the accumulator then the 
+           topmost get to be the heavier bits) */
+        print_instr("COMPINT31");
+        int i;
+        /*accu=accu or accu = (value)((unsigned long)1-accu) if bool
+	               is used for the bits */
+        for(i=0; i < 30; i++) {
+	  accu = (value) ((((uint32)accu-1) << 1) | *sp++);
+          /* -1 removes the tag bit, << 1 multiplies the value by 2, 
+              | *sp++ pops the last value and add it (no carry involved)
+	      not that it reintroduces a tag bit */
+          /* alternative, if bool is used for the bits :
+	     accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */
+        }
+        Next;
+      }
+
+      Instruct (DECOMPINT31) {
+        /* builds a block out of a 31-bit integer (from the accumulator), 
+           used before cases */
+        int i;
+	value block;
+	print_instr("DECOMPINT31");
+        Alloc_small(block, 31, 1); // Alloc_small(*, size, tag)
+        for(i = 30; i >= 0; i--) {
+          Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */
+          //Field(block, i) = 3;
+          accu = (value) ((uint32)accu >> 1) | 1;  /* last bit must be a one */
+        };
+	accu = block;
+        Next;
+      }
+
+
+
+      /*  /spiwack   */
+
+
+
 /* Debugging and machine control */
 
       Instruct(STOP){
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
new file mode 100644
index 00000000..0a61ad79
--- /dev/null
+++ b/kernel/byterun/int64_emul.h
@@ -0,0 +1,272 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2002 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $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.  */
+
+#ifndef CAML_INT64_EMUL_H
+#define CAML_INT64_EMUL_H
+
+#include <math.h>
+
+#ifdef ARCH_BIG_ENDIAN
+#define I64_literal(hi,lo) { hi, lo }
+#else
+#define I64_literal(hi,lo) { lo, hi }
+#endif
+
+/* Unsigned comparison */
+static int I64_ucompare(uint64 x, uint64 y)
+{
+  if (x.h > y.h) return 1;
+  if (x.h < y.h) return -1;
+  if (x.l > y.l) return 1;
+  if (x.l < y.l) return -1;
+  return 0;
+}
+
+#define I64_ult(x, y) (I64_ucompare(x, y) < 0)
+
+/* Signed comparison */
+static int I64_compare(int64 x, int64 y)
+{
+  if ((int32)x.h > (int32)y.h) return 1;
+  if ((int32)x.h < (int32)y.h) return -1;
+  if (x.l > y.l) return 1;
+  if (x.l < y.l) return -1;
+  return 0;
+}
+
+/* Negation */
+static int64 I64_neg(int64 x)
+{
+  int64 res;
+  res.l = -x.l;
+  res.h = ~x.h;
+  if (res.l == 0) res.h++;
+  return res;
+}
+
+/* Addition */
+static int64 I64_add(int64 x, int64 y)
+{
+  int64 res;
+  res.l = x.l + y.l;
+  res.h = x.h + y.h;
+  if (res.l < x.l) res.h++;
+  return res;
+}
+
+/* Subtraction */
+static int64 I64_sub(int64 x, int64 y)
+{
+  int64 res;
+  res.l = x.l - y.l;
+  res.h = x.h - y.h;
+  if (x.l < y.l) res.h--;
+  return res;
+}
+
+/* Multiplication */
+static int64 I64_mul(int64 x, int64 y)
+{
+  int64 res;
+  uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF);
+  uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF);
+  uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16);
+  uint32 prod11 = (x.l >> 16) * (y.l >> 16);
+  res.l = prod00;
+  res.h = prod11 + (prod01 >> 16) + (prod10 >> 16);
+  prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++;
+  prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++;
+  res.h += x.l * y.h + x.h * y.l;
+  return res;
+}
+
+#define I64_is_zero(x) (((x).l | (x).h) == 0)
+
+#define I64_is_negative(x) ((int32) (x).h < 0)
+
+/* Bitwise operations */
+static int64 I64_and(int64 x, int64 y)
+{
+  int64 res;
+  res.l = x.l & y.l;
+  res.h = x.h & y.h;
+  return res;
+}
+
+static int64 I64_or(int64 x, int64 y)
+{
+  int64 res;
+  res.l = x.l | y.l;
+  res.h = x.h | y.h;
+  return res;
+}
+
+static int64 I64_xor(int64 x, int64 y)
+{
+  int64 res;
+  res.l = x.l ^ y.l;
+  res.h = x.h ^ y.h;
+  return res;
+}
+
+/* Shifts */
+static int64 I64_lsl(int64 x, int s)
+{
+  int64 res;
+  s = s & 63;
+  if (s == 0) return x;
+  if (s < 32) {
+    res.l = x.l << s;
+    res.h = (x.h << s) | (x.l >> (32 - s));
+  } else {
+    res.l = 0;
+    res.h = x.l << (s - 32);
+  }
+  return res;
+}
+
+static int64 I64_lsr(int64 x, int s)
+{
+  int64 res;
+  s = s & 63;
+  if (s == 0) return x;
+  if (s < 32) {
+    res.l = (x.l >> s) | (x.h << (32 - s));
+    res.h = x.h >> s;
+  } else {
+    res.l = x.h >> (s - 32);
+    res.h = 0;
+  }
+  return res;
+}
+
+static int64 I64_asr(int64 x, int s)
+{
+  int64 res;
+  s = s & 63;
+  if (s == 0) return x;
+  if (s < 32) {
+    res.l = (x.l >> s) | (x.h << (32 - s));
+    res.h = (int32) x.h >> s;
+  } else {
+    res.l = (int32) x.h >> (s - 32);
+    res.h = (int32) x.h >> 31;
+  }
+  return res;
+}
+
+/* Division and modulus */
+
+#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1
+#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1
+
+static void I64_udivmod(uint64 modulus, uint64 divisor,
+                        uint64 * quo, uint64 * mod)
+{
+  int64 quotient, mask;
+  int cmp;
+
+  quotient.h = 0; quotient.l = 0;
+  mask.h = 0; mask.l = 1;
+  while ((int32) divisor.h >= 0) {
+    cmp = I64_ucompare(divisor, modulus);
+    I64_SHL1(divisor);
+    I64_SHL1(mask);
+    if (cmp >= 0) break;
+  }
+  while (mask.l | mask.h) {
+    if (I64_ucompare(modulus, divisor) >= 0) {
+      quotient.h |= mask.h; quotient.l |= mask.l;
+      modulus = I64_sub(modulus, divisor);
+    }
+    I64_SHR1(mask);
+    I64_SHR1(divisor);
+  }
+  *quo = quotient;
+  *mod = modulus;
+}
+
+static int64 I64_div(int64 x, int64 y)
+{
+  int64 q, r;
+  int32 sign;
+
+  sign = x.h ^ y.h;
+  if ((int32) x.h < 0) x = I64_neg(x);
+  if ((int32) y.h < 0) y = I64_neg(y);
+  I64_udivmod(x, y, &q, &r);
+  if (sign < 0) q = I64_neg(q);
+  return q;
+}
+
+static int64 I64_mod(int64 x, int64 y)
+{
+  int64 q, r;
+  int32 sign;
+
+  sign = x.h;
+  if ((int32) x.h < 0) x = I64_neg(x);
+  if ((int32) y.h < 0) y = I64_neg(y);
+  I64_udivmod(x, y, &q, &r);
+  if (sign < 0) r = I64_neg(r);
+  return r;
+}
+
+/* Coercions */
+
+static int64 I64_of_int32(int32 x)
+{
+  int64 res;
+  res.l = x;
+  res.h = x >> 31;
+  return res;
+}
+
+#define I64_to_int32(x) ((int32) (x).l)
+
+/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise
+   autoconfiguration would have selected native 64-bit integers */
+#define I64_of_intnat I64_of_int32
+#define I64_to_intnat I64_to_int32
+
+static double I64_to_double(int64 x)
+{
+  double res;
+  int32 sign = x.h;
+  if (sign < 0) x = I64_neg(x);
+  res = ldexp((double) x.h, 32) + x.l;
+  if (sign < 0) res = -res;
+  return res;
+}
+
+static int64 I64_of_double(double f)
+{
+  int64 res;
+  double frac, integ;
+  int neg;
+
+  neg = (f < 0);
+  f = fabs(f);
+  frac = modf(ldexp(f, -32), &integ);
+  res.h = (uint32) integ;
+  res.l = (uint32) ldexp(frac, 32);
+  if (neg) res = I64_neg(res);
+  return res;
+}
+
+#endif /* CAML_INT64_EMUL_H */
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
new file mode 100644
index 00000000..4fc3c220
--- /dev/null
+++ b/kernel/byterun/int64_native.h
@@ -0,0 +1,50 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2002 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $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 */
+
+#ifndef CAML_INT64_NATIVE_H
+#define CAML_INT64_NATIVE_H
+
+#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo))
+#define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
+#define I64_ult(x,y) ((uint64)(x) < (uint64)(y))
+#define I64_neg(x) (-(x))
+#define I64_add(x,y) ((x) + (y))
+#define I64_sub(x,y) ((x) - (y))
+#define I64_mul(x,y) ((x) * (y))
+#define I64_is_zero(x) ((x) == 0)
+#define I64_is_negative(x) ((x) < 0)
+#define I64_div(x,y) ((x) / (y))
+#define I64_mod(x,y) ((x) % (y))
+#define I64_udivmod(x,y,quo,rem) \
+  (*(rem) = (uint64)(x) % (uint64)(y), \
+   *(quo) = (uint64)(x) / (uint64)(y))
+#define I64_and(x,y) ((x) & (y))
+#define I64_or(x,y) ((x) | (y))
+#define I64_xor(x,y) ((x) ^ (y))
+#define I64_lsl(x,y) ((x) << (y))
+#define I64_asr(x,y) ((x) >> (y))
+#define I64_lsr(x,y) ((uint64)(x) >> (y))
+#define I64_to_intnat(x) ((intnat) (x))
+#define I64_of_intnat(x) ((intnat) (x))
+#define I64_to_int32(x) ((int32) (x))
+#define I64_of_int32(x) ((int64) (x))
+#define I64_to_double(x) ((double)(x))
+#define I64_of_double(x) ((int64)(x))
+
+#endif /* CAML_INT64_NATIVE_H */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index a9b16f29..ceba6e82 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -17,6 +17,7 @@ type structured_constant =
   | Const_b0 of tag                
   | Const_bn of tag * structured_constant array
 
+
 type reloc_table = (tag * int) array 
 
 type annot_switch = 
@@ -63,6 +64,43 @@ type instruction =
   | Ksetfield of int
   | Kstop
   | Ksequence of bytecodes * bytecodes
+(* spiwack: instructions concerning integers *)
+  | Kbranch of Label.t                  (* jump to label *)
+  | 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
+					   int31, for exact computation *)
+  | 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
+					   is a pair of the quotient and the 
+					   rest.
+					   If the divisor is 0, it returns
+					   0. *)
+  | Kdivint31                           (* euclidian division (returns a pair
+					   quotient,rest) *)
+  | 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
+					   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 
+                                           ie low bits *)
+  | Kisconst of Label.t                 (* conditional jump *)
+  | Kareconst of int*Label.t            (* conditional jump *)
+  | Kcompint31                          (* dynamic compilation of int31 *)
+  | Kdecompint31                        (* dynamic decompilation of int31 *)
+(* /spiwack *)
 
 and bytecodes = instruction list
 
@@ -70,6 +108,31 @@ 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
+            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] *)
+  }    
+   
+   
+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              *)
+    offset : int;                 
+    in_env : vm_env ref 
+  } 
+
+
 
 (* --- Pretty print *)
 open Format
@@ -123,6 +186,29 @@ let rec instruction ppf = function
   | Kstop -> fprintf ppf "\tstop"
   | Ksequence (c1,c2) ->
       fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 
+(* spiwack *)
+  | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl
+  | Kaddint31 -> fprintf ppf "\taddint31"
+  | Kaddcint31 -> fprintf ppf "\taddcint31"
+  | Kaddcarrycint31 -> fprintf ppf "\taddcarrycint31"
+  | Ksubint31 -> fprintf ppf "\tsubint31"
+  | Ksubcint31 -> fprintf ppf "\tsubcint31"
+  | Ksubcarrycint31 -> fprintf ppf "\tsubcarrycint31"
+  | Kmulint31 -> fprintf ppf "\tmulint31"
+  | Kmulcint31 -> fprintf ppf "\tmulcint31"
+  | Kdiv21int31 -> fprintf ppf "\tdiv21int31"
+  | Kdivint31 -> fprintf ppf "\tdivint31"
+  | Kcompareint31 -> fprintf ppf "\tcompareint31"
+  | Khead0int31 -> fprintf ppf "\thead0int31"
+  | Ktail0int31 -> fprintf ppf "\ttail0int31"
+  | Kaddmuldivint31 -> fprintf ppf "\taddmuldivint31"
+  | Kisconst lbl -> fprintf ppf "\tisconst %i" lbl
+  | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl
+  | Kcompint31 -> fprintf ppf "\tcompint31"
+  | Kdecompint31 -> fprintf ppf "\tdecompint"
+
+(* /spiwack *)
+
 
 and instruction_list ppf = function
     [] -> ()
@@ -130,6 +216,22 @@ and instruction_list ppf = function
       fprintf ppf "L%i:%a" lbl instruction_list il
   | instr :: il ->
       fprintf ppf "%a@ %a" instruction instr instruction_list il
+
+
+(*spiwack: moved this type in this file  because I needed it for 
+  retroknowledge which can't depend from cbytegen *)
+type block = 
+  | Bconstr of constr
+  | Bstrconst of structured_constant
+  | Bmakeblock of int * block array
+  | Bconstruct_app of int * int * int * block array
+                  (* tag , nparams, arity *)
+  | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
+                (* spiwack: compilation given by a function *)
+                (* compilation function (see get_vm_constant_dynamic_info in 
+                   retroknowledge.mli for more info) , argument array  *)
+
+
  
 let draw_instr c =
   fprintf std_formatter "@[<v 0>%a@]" instruction_list c
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index 215b6ad4..c24b5a53 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -61,6 +61,43 @@ type instruction =
   | 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 
+                                           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
+					   int31, for exact computation *)
+  | 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
+					   is a pair of the quotient and the 
+					   rest.
+					   If the divisor is 0, it returns
+					   0. *)
+  | Kdivint31                           (* euclidian division (returns a pair
+					   quotient,rest) *)
+  | 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
+					   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 
+                                           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 *)
 
 
 and bytecodes = instruction list
@@ -69,5 +106,41 @@ 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
+            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] *)
+  }    
+   
+   
+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              *)
+    offset : int;                 
+    in_env : vm_env ref 
+  } 
+
 val draw_instr : bytecodes -> unit
 
+
+
+(*spiwack: moved this here because I needed it for retroknowledge *)
+type block = 
+  | Bconstr of constr
+  | Bstrconst of structured_constant
+  | Bmakeblock of int * block array
+  | Bconstruct_app of int * int * int * block array
+                  (* tag , nparams, arity *)
+  | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
+                (* 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 e1f89fad..72113425 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -83,24 +83,9 @@ open Pre_env
    
 (* On conserve la fct de cofix pour la conversion                         *)
    
-type vm_env = {
-    size : int;              (* longueur de la liste [n] *)
-    fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
-  }    
-   
+    
 let empty_fv = { size= 0;  fv_rev = [] }
-   
-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              *)
-    offset : int;                 
-    in_env : vm_env ref 
-  } 
-
+  
 let fv r = !(r.in_env)
    
 let empty_comp_env ()= 
@@ -231,17 +216,40 @@ let rec discard_dead_code cont = cont
 
 let label_code = function
   | Klabel lbl :: _ as cont -> (lbl, cont)
+  | Kbranch lbl :: _ as cont -> (lbl, cont)
   | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont)
 
 (* Return a branch to the continuation. That is, an instruction that,
    when executed, branches to the continuation or performs what the
    continuation performs. We avoid generating branches to returns. *)
-
+(* spiwack: make_branch was only used once. Changed it back to the ZAM
+      one to match the appropriate semantics (old one avoided the 
+      introduction of an unconditional branch operation, which seemed
+      appropriate for the 31-bit integers' code). As a memory, I leave
+      the former version in this comment.
 let make_branch cont =
   match cont with
   | (Kreturn _ as return) :: cont' -> return, cont'
   | Klabel lbl as b :: _ -> b, cont
   | _ -> let b = Klabel(Label.create()) in b,b::cont
+*)
+
+let rec make_branch_2 lbl n cont =
+  function
+    Kreturn m :: _ -> (Kreturn (n + m), cont)
+  | Klabel _ :: c  -> make_branch_2 lbl n cont c
+  | Kpop m :: c    -> make_branch_2 lbl (n + m) cont c
+  | _              ->
+      match lbl with
+        Some lbl -> (Kbranch lbl, cont)
+      | None     -> let lbl = Label.create() in (Kbranch lbl, Klabel lbl :: cont)
+
+let make_branch cont =
+  match cont with
+    (Kbranch _ as branch) :: _ -> (branch, cont)
+  | (Kreturn _ as return) :: _ -> (return, cont)
+  | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
+  | _ ->  make_branch_2 (None) 0 cont cont
 
 (* Check if we're in tailcall position *)
 
@@ -315,52 +323,105 @@ let code_construct tag nparams arity cont =
     fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)];
     Kclosure(lbl,0) :: cont
 
-type block = 
-  | Bconstr of constr
-  | Bstrconst of structured_constant
-  | Bmakeblock of int * block array
-  | Bconstruct_app of int * int * int * block array
-                  (* tag , nparams, arity *)
-
 let get_strcst = function
   | Bstrconst sc -> sc
   | _ -> raise Not_found 
 
-let rec str_const c =
+
+let rec str_const c = 
   match kind_of_term c with
   | Sort s -> Bstrconst (Const_sorts s)
   | Cast(c,_,_) -> str_const c 
   | App(f,args) -> 
       begin
 	match kind_of_term f with
-	| Construct((kn,j),i) -> 
+	| Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *)
+            begin
 	    let oib = lookup_mind kn !global_env in
 	    let oip = oib.mind_packets.(j) in
 	    let num,arity = oip.mind_reloc_tbl.(i-1) in
 	    let nparams = oib.mind_nparams in
 	    if nparams + arity = Array.length args then
-	      if arity = 0 then Bstrconst(Const_b0 num)
-	      else
-		let rargs = Array.sub args nparams arity in
-		let b_args = Array.map str_const rargs in
-		try 
-		  let sc_args = Array.map get_strcst b_args in
-		  Bstrconst(Const_bn(num, sc_args))
-		with Not_found ->
-		  Bmakeblock(num,b_args)
+              (* spiwack: *)
+              (* 1/ tries to compile the constructor in an optimal way,
+                    it is supposed to work only if the arguments are
+                    all fully constructed, fails with Cbytecodes.NotClosed. 
+                    it can also raise Not_found when there is no special
+                    treatment for this constructor 
+                    for instance: tries to to compile an integer of the 
+                        form I31 D1 D2 ... D31 to [D1D2...D31] as 
+                        a processor number (a caml number actually) *)
+              try 
+		try
+		  Bstrconst (Retroknowledge.get_vm_constant_static_info 
+                                              (!global_env).retroknowledge
+                                              (kind_of_term f) args)
+                with NotClosed ->
+		  (* 2/ if the arguments are not all closed (this is 
+                        expectingly (and it is currently the case) the only 
+                        reason why this exception is raised) tries to 
+                        give a clever, run-time behavior to the constructor.
+                        Raises Not_found if there is no special treatment
+                        for this integer.
+                        this is done in a lazy fashion, using the constructor
+                        Bspecial because it needs to know the continuation
+                        and such, which can't be done at this time.
+                        for instance, for int31: if one of the digit is 
+                            not closed, it's not impossible that the number
+                            gets fully instanciated at run-time, thus to ensure
+                            uniqueness of the representation in the vm
+                            it is necessary to try and build a caml integer 
+                            during the execution *)
+		  let rargs = Array.sub args nparams arity in
+		  let b_args = Array.map str_const rargs in
+		  Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
+                                           (!global_env).retroknowledge
+                                           (kind_of_term f)),
+                           b_args)
+              with Not_found ->
+		(* 3/ if no special behavior is available, then the compiler
+		      falls back to the normal behavior *)
+		if arity = 0 then Bstrconst(Const_b0 num)
+		else
+		  let rargs = Array.sub args nparams arity in
+		  let b_args = Array.map str_const rargs in
+		  try 
+		    let sc_args = Array.map get_strcst b_args in
+		    Bstrconst(Const_bn(num, sc_args))
+		  with Not_found ->
+		    Bmakeblock(num,b_args)
 	    else  
-	      let b_args = Array.map str_const args in
-	      Bconstruct_app(num, nparams, arity, b_args)
+              let b_args = Array.map str_const args in
+	     (* spiwack: tries first to apply the run-time compilation
+                behavior of the constructor, as in 2/ above *)
+	      try 
+		Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
+                                           (!global_env).retroknowledge
+                                           (kind_of_term f)),
+                         b_args)
+	      with Not_found ->
+	        Bconstruct_app(num, nparams, arity, b_args)
+              end
 	| _ -> Bconstr c
       end
   | Ind ind -> Bstrconst (Const_ind ind)
-  | Construct ((kn,j),i) ->  
-      let oib = lookup_mind kn !global_env in 
-      let oip = oib.mind_packets.(j) in
-      let num,arity = oip.mind_reloc_tbl.(i-1) in
-      let nparams = oib.mind_nparams in
-      if nparams + arity = 0 then Bstrconst(Const_b0 num)
-      else Bconstruct_app(num,nparams,arity,[||])
+  | Construct ((kn,j),i) ->  (*arnaud: Construct ((kn,j),i as cstr) ->  *)
+      begin
+      (* spiwack: tries first to apply the run-time compilation 
+           behavior of the constructor, as in 2/ above *)
+      try
+	Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
+                                           (!global_env).retroknowledge
+                                           (kind_of_term c)),
+                         [| |])
+      with Not_found ->
+	let oib = lookup_mind kn !global_env in 
+	let oip = oib.mind_packets.(j) in
+	let num,arity = oip.mind_reloc_tbl.(i-1) in
+	let nparams = oib.mind_nparams in
+	if nparams + arity = 0 then Bstrconst(Const_b0 num)
+	else Bconstruct_app(num,nparams,arity,[||])
+      end
   | _ -> Bconstr c
 
 (* compilation des applications *)
@@ -413,6 +474,7 @@ let rec get_allias env kn =
   | BCallias kn' -> get_allias env kn'
   | _ -> kn
 
+  
 (* compilation des expressions *)
  
 let rec compile_constr reloc c sz cont =
@@ -424,8 +486,7 @@ let rec compile_constr reloc c sz cont =
 
   | Rel i -> pos_rel i reloc sz :: cont
   | Var id -> pos_named id reloc :: cont
-  | Const kn -> Kgetglobal (get_allias !global_env kn) :: cont
-  
+  | Const kn -> compile_const reloc kn [||] sz cont
   | Sort _  | Ind _ | Construct _ ->
       compile_str_cst reloc (str_const c) sz cont
   
@@ -452,6 +513,7 @@ let rec compile_constr reloc c sz cont =
       begin 
 	match kind_of_term f with
 	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
+        | Const kn -> compile_const reloc kn args sz cont
 	| _ -> comp_app compile_constr compile_constr reloc f args sz cont 
       end
   | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
@@ -569,11 +631,19 @@ let rec compile_constr reloc c sz cont =
       done;
       c :=  Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c;
       let code_sw = 
-	match branch1 with
-	| Klabel lbl -> Kpush_retaddr lbl ::  !c
+ 	match branch1 with 
+        (* spiwack : branch1 can't be a lbl anymore it's a Branch instead 
+	| Klabel lbl -> Kpush_retaddr lbl ::  !c *)
+        | Kbranch lbl -> Kpush_retaddr lbl ::  !c
 	| _ -> !c 
       in
-      compile_constr reloc a sz code_sw
+      compile_constr reloc a sz 
+      (try 
+	let entry = Term.Ind ind in
+	Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge
+	                                       entry code_sw
+      with Not_found ->
+	code_sw)
        
 and compile_str_cst reloc sc sz cont =
   match sc with
@@ -588,6 +658,40 @@ and compile_str_cst reloc sc sz cont =
 	comp_app 
 	  (fun _ _ _ cont -> code_construct tag nparams arity cont) 
 	  compile_str_cst reloc () args sz cont
+  | Bspecial (comp_fx, args) -> comp_fx reloc args 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
+              if there is not, Not_found is raised, and the function
+              falls back on its normal behavior *)
+  try
+    Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge
+                  (kind_of_term (mkConst kn)) reloc args sz cont
+  with Not_found -> 
+    if nargs = 0 then
+      Kgetglobal (get_allias !global_env kn) :: cont
+    else
+      comp_app (fun _ _ _ cont -> 
+                   Kgetglobal (get_allias !global_env kn) :: cont)
+        compile_constr reloc () args sz cont
       
 let compile env c =
   set_global_env env;
@@ -625,3 +729,138 @@ let compile_constant_body env body opaque boxed =
 	    let to_patch = to_memory res in
 	    BCdefined (false, to_patch)
 
+
+(* spiwack: additional function which allow different part of compilation of the
+      31-bit integers *)
+
+let make_areconst n else_lbl cont =
+  if n <=0 then
+    cont
+  else
+    Kareconst (n, else_lbl)::cont
+
+
+(* try to compile int31 as a const_b0. Succeed if all the arguments are closed
+   fails otherwise by raising NotClosed*)
+let compile_structured_int31 fc args =
+  if not fc then raise Not_found else 
+  Const_b0
+    (Array.fold_left 
+       (fun temp_i -> fun t -> match kind_of_term t with
+          | Construct (_,d) -> 2*temp_i+d-1
+          | _ -> raise NotClosed)
+       0 args
+    )
+
+(* this function is used for the compilation of the constructor of
+   the int31, it is used when it appears not fully applied, or 
+   applied to at least one non-closed digit *)
+let dynamic_int31_compilation fc reloc args sz cont =
+  if not fc then raise Not_found else
+    let nargs = Array.length args in
+      if nargs = 31 then
+	let (escape,labeled_cont) = make_branch cont in
+	let else_lbl = Label.create() in
+	  comp_args compile_str_cst reloc args sz 
+            ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont)
+      else 
+	let code_construct cont = (* spiwack: variant of the global code_construct
+                                     which handles dynamic compilation of 
+                                     integers *)
+          let f_cont = 
+            let else_lbl = Label.create () in
+	      [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl);
+               Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0]
+	  in 
+	  let lbl = Label.create() in
+	    fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)];
+	    Kclosure(lbl,0) :: cont
+	in 
+	  if nargs = 0 then
+	    code_construct cont
+	  else
+	    comp_app (fun _ _ _ cont -> code_construct cont)
+              compile_str_cst reloc () args sz cont
+       
+(*(* template compilation for 2ary operation, it probably possible
+   to make a generic such function with arity abstracted *)
+let op2_compilation op =
+  let code_construct normal cont =  (*kn cont =*)
+     let f_cont = 
+         let else_lbl = Label.create () in
+         Kareconst(2, else_lbl):: Kacc 0:: Kpop 1::
+          op:: Kreturn 0:: Klabel else_lbl::
+         (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*)
+          (*Kgetglobal (get_allias !global_env kn):: *)
+          normal::
+          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 normal fc _ reloc args sz cont ->
+  if not fc then raise Not_found else
+  let nargs = Array.length args in
+  if nargs=2 then (*if it is a fully applied addition*)
+    let (escape, labeled_cont) = make_branch cont in
+    let else_lbl = Label.create () in
+      comp_args compile_constr reloc args sz 
+	(Kisconst else_lbl::(make_areconst 1  else_lbl 
+           (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
+           (op::escape::Klabel else_lbl::Kpush::
+           (* works as comp_app with nargs = 2 and non-tailcall cont*)
+           (*Kgetglobal (get_allias !global_env kn):: *)
+           normal::
+           Kapply 2::labeled_cont)))
+  else if nargs=0 then
+    code_construct normal cont
+  else
+    comp_app (fun _ _ _ cont -> code_construct normal cont)
+      compile_constr reloc () args sz cont *)
+
+(*template for n-ary operation, invariant: n>=1,
+  the operations does the following : 
+  1/ checks if all the arguments are constants (i.e. non-block values) 
+  2/ if they are, uses the "op" instruction to execute
+  3/ if at least one is not, branches to the normal behavior: 
+      Kgetglobal (get_allias !global_env kn) *)
+let op_compilation n op =
+  let code_construct kn cont = 
+     let f_cont = 
+         let else_lbl = Label.create () in
+         Kareconst(n, else_lbl):: Kacc 0:: Kpop 1::
+          op:: Kreturn 0:: Klabel else_lbl::
+         (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*)
+          Kgetglobal (get_allias !global_env kn)::
+          Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *)
+     in
+     let lbl = Label.create () in 
+     fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)];
+     Kclosure(lbl, 0)::cont
+  in
+  fun kn fc reloc args sz cont ->
+  if not fc then raise Not_found else
+  let nargs = Array.length args in
+  if nargs=n then (*if it is a fully applied addition*)
+    let (escape, labeled_cont) = make_branch cont in
+    let else_lbl = Label.create () in
+      comp_args compile_constr reloc args sz 
+	(Kisconst else_lbl::(make_areconst (n-1) else_lbl 
+           (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
+           (op::escape::Klabel else_lbl::Kpush::
+           (* works as comp_app with nargs = n and non-tailcall cont*)
+           Kgetglobal (get_allias !global_env kn)::
+           Kapply n::labeled_cont)))
+  else if nargs=0 then
+    code_construct kn cont
+  else
+    comp_app (fun _ _ _ cont -> code_construct kn cont)
+      compile_constr reloc () args sz cont
+
+let int31_escape_before_match fc cont =
+  if not fc then
+    raise Not_found
+  else
+    let escape_lbl, labeled_cont = label_code cont in
+      (Kisconst escape_lbl)::Kdecompint31::labeled_cont
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index f761e4f6..dfdcb074 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -6,7 +6,6 @@ open Declarations
 open Pre_env
 
 
-
 val compile : env -> constr -> bytecodes * bytecodes * fv
                               (* init, fun, fv *)
 
@@ -15,3 +14,27 @@ val compile_constant_body :
                                  (* opaque *) (* boxed *)
 
 
+(* 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
+        the dynamic compilation of int31 (trying and obtaining a
+        31-bit integer in processor representation at runtime when
+        it failed at compile time *)
+val dynamic_int31_compilation : bool -> comp_env -> 
+                                block array -> 
+                                int -> bytecodes -> bytecodes
+
+(*spiwack: template for the compilation n-ary operation, invariant: n>=1.
+           works as follow: checks if all the arguments are non-pointers
+           if they are applies the operation (second argument) if not
+           all of them are, returns to a coq definition (third argument) *)
+val op_compilation : int -> instruction -> constant -> bool -> comp_env ->
+                             constr array -> int -> bytecodes-> bytecodes
+
+(*spiwack: compiling function to insert dynamic decompilation before 
+           matching integers (in case they are in processor representation) *)
+val int31_escape_before_match : bool -> bytecodes -> bytecodes
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 4e09a0ed..7617c454 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -23,6 +23,7 @@ let patch_int buff pos n =
 
 let out_buffer = ref(String.create 1024)
 and out_position = ref 0
+
 (*
 let out_word b1 b2 b3 b4 =
   let p = !out_position in
@@ -38,6 +39,7 @@ let out_word b1 b2 b3 b4 =
   String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
   out_position := p + 4
 *)
+
 let out_word b1 b2 b3 b4 =
   let p = !out_position in
   if p >= String.length !out_buffer then begin
@@ -60,6 +62,7 @@ let out_word b1 b2 b3 b4 =
   String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
   out_position := p + 4
 
+
 let out opcode =
   out_word opcode 0 0 0
 
@@ -108,7 +111,10 @@ let out_label_with_orig orig lbl =
     Label_defined def ->
       out_int((def - orig) asr 2)
   | Label_undefined patchlist ->
-      if patchlist = [] then
+      (* spiwack: patchlist is supposed to be non-empty all the time
+         thus I commented that out. If there is no problem I suggest
+         removing it for next release (cur: 8.1) *)
+      (*if patchlist = [] then *)
 	(!label_table).(lbl) <-
           Label_undefined((!out_position, orig) :: patchlist);
       out_int 0
@@ -219,9 +225,30 @@ let emit_instr = function
   | Ksetfield n ->
       if n <= 1 then out (opSETFIELD0+n) 
       else (out opSETFIELD;out_int n)
+  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
+  (* spiwack *)
+  | Kbranch lbl -> out opBRANCH; out_label lbl
+  | Kaddint31 -> out opADDINT31
+  | Kaddcint31 -> out opADDCINT31
+  | Kaddcarrycint31 -> out opADDCARRYCINT31
+  | Ksubint31 -> out opSUBINT31
+  | Ksubcint31 -> out opSUBCINT31
+  | Ksubcarrycint31 -> out opSUBCARRYCINT31
+  | Kmulint31 -> out opMULINT31
+  | Kmulcint31 -> out opMULCINT31
+  | Kdiv21int31 -> out opDIV21INT31
+  | Kdivint31 -> out opDIVINT31
+  | Kaddmuldivint31 -> out opADDMULDIVINT31
+  | Kcompareint31 -> out opCOMPAREINT31
+  | Khead0int31 -> out opHEAD0INT31
+  | Ktail0int31 -> out opTAIL0INT31
+  | Kisconst lbl -> out opISCONST; out_label lbl
+  | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl
+  | Kcompint31 -> out opCOMPINT31
+  | Kdecompint31 -> out opDECOMPINT31
+  (*/spiwack *)
   | Kstop -> 
       out opSTOP
-  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
 
 (* Emission of a list of instructions. Include some peephole optimization. *)
 
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 41fe8750..b85be204 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
+(* $Id: closure.ml 10819 2008-04-20 18:14:44Z msozeau $ *)
 
 open Util
 open Pp
@@ -165,143 +165,15 @@ let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
 let betaiota = mkflags [fBETA;fIOTA]
 let beta = mkflags [fBETA]
 let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
+
+(* Removing fZETA for finer behaviour would break many developments *)
+let unfold_side_flags = [fBETA;fIOTA;fZETA]
+let unfold_side_red = mkflags [fBETA;fIOTA;fZETA]
 let unfold_red kn = 
   let flag = match kn with
     | EvalVarRef id -> fVAR id
-    | EvalConstRef kn -> fCONST kn
-  in (* Remove fZETA for finer behaviour ? *)
-  mkflags [fBETA;flag;fIOTA;fZETA]
-
-(************************* Obsolète
-(* [r_const=(true,cl)] means all constants but those in [cl] *)
-(* [r_const=(false,cl)] means only those in [cl] *)
-type reds = {
-  r_beta : bool;
-  r_const : bool * constant_path list * identifier list;
-  r_zeta : bool;
-  r_evar : bool;
-  r_iota : bool }
-
-let betadeltaiota_red = {
-  r_beta = true;
-  r_const = true,[],[];
-  r_zeta = true;
-  r_evar = true;
-  r_iota = true } 
-
-let betaiota_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = true }
-		     
-let beta_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = false }
-
-let no_red = {
-  r_beta = false;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = false }
-
-let betaiotazeta_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = true;
-  r_evar = false;
-  r_iota = true }
-
-let unfold_red kn =
-  let c = match kn with
-    | EvalVarRef id -> false,[],[id]
-    | EvalConstRef kn -> false,[kn],[]
-  in {
-  r_beta = true;
-  r_const = c;
-  r_zeta = true;   (* false for finer behaviour ? *)
-  r_evar = false;
-  r_iota = true }
-
-(* Sets of reduction kinds.
-   Main rule: delta implies all consts (both global (= by
-   kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
-   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
-   a LetIn expression is Letin reduction *)
-
-type red_kind =
-    BETA | DELTA | ZETA | IOTA
-  | CONST of constant_path list | CONSTBUT of constant_path list
-  | VAR of identifier | VARBUT of identifier
-
-let rec red_add red = function
-  | BETA -> { red with r_beta = true }
-  | DELTA ->
-      (match red.r_const with
-	| _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags"
-	| _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true })
-  | CONST cl ->
-      (match red.r_const with
-	| true,_,_ -> error "Conflict in the reduction flags"
-	| _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 })
-  | CONSTBUT cl ->
-      (match red.r_const with
-	| false,_::_,_ | false,_,_::_ ->
-			   error "Conflict in the reduction flags"
-	| _,l1,l2 ->
-	    { red with r_const = true, list_union cl l1, l2;
-		r_zeta = true; r_evar = true })
-  | IOTA -> { red with r_iota = true }
-  | ZETA -> { red with r_zeta = true }
-  | VAR id ->
-      (match red.r_const with
-	| true,_,_ -> error "Conflict in the reduction flags"
-	| _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 })
-  | VARBUT cl ->
-      (match red.r_const with
-	| false,_::_,_ | false,_,_::_ ->
-			   error "Conflict in the reduction flags"
-	| _,l1,l2 ->
-	    { red with r_const = true, l1, list_union [cl] l2;
-		r_zeta = true; r_evar = true })
-
-let red_delta_set red =
-  let b,_,_ = red.r_const in b
-
-let red_local_const = red_delta_set
-
-(* to know if a redex is allowed, only a subset of red_kind is used ... *)
-let red_set red = function
-  | BETA -> incr_cnt red.r_beta beta
-  | CONST [kn] -> 
-      let (b,l,_) = red.r_const in
-      let c = List.mem kn l in
-      incr_cnt ((b & not c) or (c & not b)) delta
-  | VAR id -> (* En attendant d'avoir des kn pour les Var *)
-     let (b,_,l) = red.r_const in
-      let c = List.mem id l in
-      incr_cnt ((b & not c) or (c & not b)) delta
-  | ZETA -> incr_cnt red.r_zeta zeta
-  | EVAR -> incr_cnt red.r_zeta evar
-  | IOTA -> incr_cnt red.r_iota iota
-  | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*)
-  (* Not for internal use *)
-  | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented"
-
-(* Gives the constant list *)
-let red_get_const red =
-  let b,l1,l2 = red.r_const in
-  let l1' = List.map (fun x -> EvalConstRef x) l1 in
-  let l2' = List.map (fun x -> EvalVarRef x) l2 in
-  b, l1' @ l2'
-fin obsolète **************)
-(* specification of the reduction function *)
-
+    | EvalConstRef kn -> fCONST kn in
+  mkflags (flag::unfold_side_flags)
 
 (* Flags of reduction and cache of constants: 'a is a type that may be
  * mapped to constr. 'a infos implements a cache for constants and
@@ -980,7 +852,7 @@ and knht e t stk =
 
 (************************************************************************)
 
-(* Computes a normal form from the result of knh. *)
+(* Computes a weak head normal form from the result of knh. *)
 let rec knr info m stk =
   match m.term with
   | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
@@ -1082,6 +954,11 @@ and norm_head info m =
           let fbds =
             Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
           mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+      | FFix((n,(na,tys,bds)),e) ->
+          let ftys = Array.map (mk_clos e) tys in
+          let fbds =
+            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
+          mkFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
       | FEvar(i,args) -> mkEvar(i, Array.map (kl info) args)
       | t -> term_of_fconstr m
 
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 924da0a5..c814baad 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli 9215 2006-10-05 15:40:31Z herbelin $ i*)
+(*i $Id: closure.mli 10652 2008-03-10 21:52:06Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -37,11 +37,7 @@ module type RedFlagsSig = sig
   type reds
   type red_kind
 
-  (* The different kind of reduction *)
-  (* Const/Var means the reference as argument should be unfolded *)
-  (* Constbut/Varbut means all references except the ones as argument
-     of Constbut/Varbut should be unfolded (there may be several such
-     Constbut/Varbut *)
+  (* The different kinds of reduction *)
   val fBETA : red_kind
   val fDELTA : red_kind
   val fIOTA : red_kind
@@ -80,6 +76,7 @@ val betadeltaiota      : reds
 val betaiotazeta       : reds
 val betadeltaiotanolet : reds
 
+val unfold_side_red : reds
 val unfold_red : evaluable_global_reference -> reds
 
 (***********************************************************************)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 4c692308..898a1ab3 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -6,37 +6,71 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml 6303 2004-11-16 12:37:40Z sacerdot $ *)
+(* $Id: conv_oracle.ml 10961 2008-05-21 23:26:23Z barras $ *)
 
 open Names
 
-(* Opaque constants *)
-let cst_transp = ref Cpred.full
+(* 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 is [Level 100].
+ *)
+type level = Expand | Level of int | Opaque
+let default = Level 0
+let transparent = default
 
-let set_opaque_const kn = cst_transp := Cpred.remove kn !cst_transp
-let set_transparent_const kn = cst_transp := Cpred.add kn !cst_transp
+type oracle = level Idmap.t * level Cmap.t
 
-let is_opaque_cst kn = not (Cpred.mem kn !cst_transp)
+let var_opacity = ref Idmap.empty
+let cst_opacity = ref Cmap.empty
 
-(* Opaque variables *)
-let var_transp = ref Idpred.full
+let get_strategy = function
+  | VarKey id ->
+      (try Idmap.find id !var_opacity
+      with Not_found -> default)
+  | ConstKey c ->
+      (try Cmap.find c !cst_opacity
+      with Not_found -> default)
+  | RelKey _ -> Expand
 
-let set_opaque_var kn = var_transp := Idpred.remove kn !var_transp
-let set_transparent_var kn = var_transp := Idpred.add kn !var_transp
+let set_strategy k l =
+  match k with
+  | VarKey id ->
+      var_opacity :=
+      if l=default then Idmap.remove id !var_opacity
+      else Idmap.add id l !var_opacity
+  | ConstKey c ->
+      cst_opacity :=
+      if l=default then Cmap.remove c !cst_opacity
+      else Cmap.add c l !cst_opacity
+  | RelKey _ -> Util.error "set_strategy: RelKey"
 
-let is_opaque_var kn = not (Idpred.mem kn !var_transp)
+let set_transparent_const kn =
+  cst_opacity := Cmap.remove kn !cst_opacity
+let set_transparent_var id =
+  var_opacity := Idmap.remove id !var_opacity
 
-(* Opaque reference keys *)
-let is_opaque = function
-  | ConstKey cst -> is_opaque_cst cst
-  | VarKey id -> is_opaque_var id
-  | RelKey _ -> false
+let set_opaque_const kn = set_strategy (ConstKey kn) Opaque
+let set_opaque_var id = set_strategy (VarKey id) Opaque
 
-(* Unfold the first only if it is not opaque and the second is opaque *)
-let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1)
+let get_transp_state () =
+  (Idmap.fold
+    (fun id l ts -> if  l=Opaque then Idpred.remove id ts else ts)
+    !var_opacity Idpred.full,
+   Cmap.fold
+    (fun c l ts -> if  l=Opaque then Cpred.remove c ts else ts)
+    !cst_opacity Cpred.full)
+
+(* 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 =
+  match get_strategy k1, get_strategy k2 with
+    | Expand, _ -> true
+    | Level n1, Opaque -> true
+    | Level n1, Level n2 -> n1 < n2
+    | _ -> false (* expand k2 *)
 
 (* summary operations *)
-type transparent_state = Idpred.t * Cpred.t
-let init() = (cst_transp := Cpred.full; var_transp := Idpred.full)
-let freeze () = (!var_transp, !cst_transp)
-let unfreeze (vo,co) = (cst_transp := co; var_transp := vo)
+let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
+let freeze () = (!var_opacity, !cst_opacity)
+let unfreeze (vo,co) = (cst_opacity := co; var_opacity := vo)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 966edd1d..6a774b4b 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -6,30 +6,35 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id: conv_oracle.mli 10961 2008-05-21 23:26:23Z barras $ i*)
 
 open Names
 
-
 (* 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
 
-(* Changing the oracle *)
-val set_opaque_const      : constant -> unit
-val set_transparent_const : constant -> unit
+(* 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].
+ *)
+type level = Expand | Level of int | Opaque
+val transparent : level
 
-val set_opaque_var      : identifier -> unit
-val set_transparent_var : identifier -> unit
+val get_strategy : 'a tableKey -> level
 
-val is_opaque_cst : constant -> bool
-val is_opaque_var : identifier -> bool
+(* 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
 
-(* transparent state summary operations *)
+(*****************************)
+(* Summary operations *)
+type oracle
 val init     : unit -> unit
-val freeze   : unit -> transparent_state
-val unfreeze : transparent_state -> unit
+val freeze   : unit -> oracle
+val unfreeze : oracle -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 6b2a6245..e5a97897 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.ml 9320 2006-10-30 16:53:43Z barras $ i*)
+(*i $Id: cooking.ml 10877 2008-04-30 21:58:41Z herbelin $ i*)
 
 open Pp
 open Util
@@ -113,7 +113,7 @@ type recipe = {
   d_modlist : work_list }
 
 let on_body f = 
-  option_map (fun c -> Declarations.from_val (f (Declarations.force c)))
+  Option.map (fun c -> Declarations.from_val (f (Declarations.force c)))
 
 let cook_constant env r =
   let cb = r.d_from in
@@ -129,6 +129,8 @@ 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
-	Typeops.make_polymorphic_if_arity env typ in
+	let j = make_judge (force (Option.get 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)
+  (body, typ, cb.const_constraints, cb.const_opaque, boxed,false)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index 93c2ccc9..7596bce6 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: cooking.mli 9795 2007-04-25 15:13:45Z soubiran $ i*)
 
 open Names
 open Term
@@ -25,7 +25,8 @@ type recipe = {
 
 val cook_constant :
   env -> recipe -> 
-    constr_substituted option * constant_type * constraints * bool * bool
+    constr_substituted option * constant_type * constraints * bool * bool 
+  * bool
 
 (*s Utility functions used in module [Discharge]. *)
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index fc2d0925..d81b98ac 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -121,31 +121,36 @@ let rec slot_for_getglobal env kn =
     rk := Some pos;
     pos
 
-and slot_for_fv env fv=
+and slot_for_fv env fv =
   match fv with
   | FVnamed id -> 
-      let nv = lookup_named_val id env in
+      let nv = Pre_env.lookup_named_val id env in
       begin
 	match !nv with
-	| VKvalue v -> v
-	| VKaxiom id ->
-	    let v = val_of_named id in
-	    nv := VKvalue v; v
-	| VKdef c ->
-	    let v = val_of_constr (env_of_named id env) c in
-	    nv := VKvalue v; v
+	| VKvalue (v,_) -> v
+	| VKnone -> 
+	    let (_, b, _) = Sign.lookup_named id env.env_named_context in
+	    let v,d = 
+	      match b with
+		| None -> (val_of_named id, Idset.empty)
+		| Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c)
+	    in
+	      nv := VKvalue (v,d); v
       end
   | FVrel i ->
-      let rv = lookup_rel_val i env in
+      let rv = Pre_env.lookup_rel_val i env in
       begin
 	match !rv with
-	| VKvalue v -> v
-	| VKaxiom k ->
-	    let v = val_of_rel k in
-	    rv := VKvalue v; v
-	| VKdef c ->
-	    let v = val_of_constr (env_of_rel i env) c in
-	    rv := VKvalue v; v
+	| VKvalue (v, _) -> v
+	| VKnone -> 
+	    let (_, b, _) = Sign.lookup_rel i env.env_rel_context in
+	    let (v, d) =
+	      match b with 
+		| None -> (val_of_rel i, Idset.empty)
+		| Some c -> let renv =  env_of_rel i env in
+			      (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
+	    in
+	      rv := VKvalue (v,d); v
       end
  
 and eval_to_patch env (buff,pl,fv) = 
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index e5e05eb3..6e99bf79 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: declarations.ml 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -49,13 +49,14 @@ type constant_body = {
     const_body_code : Cemitcodes.to_patch_substituted;
    (* const_type_code : Cemitcodes.to_patch; *)
     const_constraints : constraints;
-    const_opaque : bool }
+    const_opaque : bool; 
+    const_inline : bool}
 
 (*s Inductive types (internal representation with redundant
     information). *)
 
 let subst_rel_declaration sub (id,copt,t as x) =
-  let copt' = option_smartmap (subst_mps sub) copt in
+  let copt' = Option.smartmap (subst_mps sub) copt in
   let t' = subst_mps sub t in
   if copt == copt' & t == t' then x else (id,copt',t')
 
@@ -197,12 +198,13 @@ let subst_arity sub = function
 (* 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_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_opaque = cb.const_opaque;
+    const_inline = cb.const_inline} 
 
 let subst_arity sub = function
 | Monomorphic s ->
@@ -239,49 +241,41 @@ let subst_mind sub mib =
       map_rel_context (subst_mps sub) mib.mind_params_ctxt;
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
     mind_constraints = mib.mind_constraints ;
-    mind_equiv = option_map (subst_kn sub) mib.mind_equiv }
+    mind_equiv = Option.map (subst_kn sub) mib.mind_equiv }
 
 
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
-type specification_body = 
-  | SPBconst of constant_body
-  | SPBmind of mutual_inductive_body
-  | SPBmodule of module_specification_body
-  | SPBmodtype of module_type_body
+type structure_field_body = 
+  | SFBconst of constant_body
+  | SFBmind of mutual_inductive_body
+  | SFBmodule of module_body
+  | SFBalias of module_path * constraints option
+  | SFBmodtype of module_type_body
 
-and module_signature_body = (label * specification_body) list
+and structure_body = (label * structure_field_body) list
 
-and module_type_body = 
-  | MTBident of kernel_name
-  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
-  | MTBsig of mod_self_id * module_signature_body
-
-and module_specification_body = 
-    { msb_modtype : module_type_body;
-      msb_equiv : module_path option; 
-      msb_constraints : constraints }
-
-type structure_elem_body = 
-  | SEBconst of constant_body
-  | SEBmind of mutual_inductive_body
-  | SEBmodule of module_body
-  | SEBmodtype of module_type_body
-
-and module_structure_body = (label * structure_elem_body) list
-
-and module_expr_body =
-  | MEBident of module_path
-  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
-  | MEBstruct of mod_self_id * module_structure_body
-  | MEBapply of module_expr_body * module_expr_body
+and struct_expr_body =
+  | SEBident of module_path
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
+  | SEBstruct of mod_self_id * structure_body
+  | SEBapply of struct_expr_body * struct_expr_body
       * constraints
+  | SEBwith of struct_expr_body * with_declaration_body
 
+and with_declaration_body =
+    With_module_body of identifier list * module_path * constraints
+  | With_definition_body of  identifier list * constant_body
+        
 and module_body = 
-    { mod_expr : module_expr_body option;
-      mod_user_type : module_type_body option;
-      mod_type : module_type_body;
-      mod_equiv : module_path option;
-      mod_constraints : constraints }
+    { mod_expr : struct_expr_body option;
+      mod_type : struct_expr_body option;
+      mod_constraints : constraints;
+      mod_alias : substitution;
+      mod_retroknowledge : Retroknowledge.action list}
 
+and module_type_body = 
+    { typ_expr : struct_expr_body;
+      typ_strength : module_path option;
+      typ_alias : substitution}
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 1eaeecb9..fa03a338 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: declarations.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Names
@@ -47,7 +47,8 @@ type constant_body = {
     const_body_code : to_patch_substituted;
    (*i const_type_code : to_patch;i*)
     const_constraints : constraints;
-    const_opaque : bool }
+    const_opaque : bool;
+    const_inline : bool}
 
 val subst_const_body : substitution -> constant_body -> constant_body
 
@@ -176,50 +177,35 @@ val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
-type specification_body = 
-  | SPBconst of constant_body
-  | SPBmind of mutual_inductive_body
-  | SPBmodule of module_specification_body
-  | SPBmodtype of module_type_body
-
-and module_signature_body = (label * specification_body) list
-
-and module_type_body = 
-  | MTBident of kernel_name
-  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
-  | MTBsig of mod_self_id * module_signature_body
-
-and module_specification_body = 
-    { msb_modtype : module_type_body;
-      msb_equiv : module_path option; 
-      msb_constraints : constraints }
-    (*    [type_of](equiv) <: modtype  (if given)  
-       +  substyping of past [With_Module] mergers *)
-
-
-type structure_elem_body = 
-  | SEBconst of constant_body
-  | SEBmind of mutual_inductive_body
-  | SEBmodule of module_body
-  | SEBmodtype of module_type_body
-
-and module_structure_body = (label * structure_elem_body) list
-
-and module_expr_body =
-  | MEBident of module_path
-  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
-  | MEBstruct of mod_self_id * module_structure_body
-  | MEBapply of module_expr_body * module_expr_body  (* (F A) *)
-      * constraints  (* [type_of](A) <: [input_type_of](F) *)
-
+type structure_field_body = 
+  | SFBconst of constant_body
+  | SFBmind of mutual_inductive_body
+  | SFBmodule of module_body
+  | SFBalias of module_path * constraints option
+  | SFBmodtype of module_type_body
+
+and structure_body = (label * structure_field_body) list
+
+and struct_expr_body =
+  | SEBident of module_path
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
+  | SEBstruct of mod_self_id * structure_body
+  | SEBapply of struct_expr_body * struct_expr_body
+      * constraints
+  | SEBwith of struct_expr_body * with_declaration_body
+
+and with_declaration_body =
+    With_module_body of identifier list * module_path * constraints
+  | With_definition_body of  identifier list * constant_body
+        
 and module_body = 
-    { mod_expr : module_expr_body option;
-      mod_user_type : module_type_body option;
-      mod_type : module_type_body;
-      mod_equiv : module_path option;
-      mod_constraints : constraints }
-    (*    [type_of(mod_expr)]  <: [mod_user_type] (if given)  *)
-    (*  if equiv given then constraints are empty *)
-
-
+    { mod_expr : struct_expr_body option;
+      mod_type : struct_expr_body option;
+      mod_constraints : constraints;
+      mod_alias : substitution;
+      mod_retroknowledge : Retroknowledge.action list}
 
+and module_type_body = 
+    { typ_expr : struct_expr_body;
+      typ_strength : module_path option;
+      typ_alias : substitution}
diff --git a/kernel/entries.ml b/kernel/entries.ml
index 56b198c3..b6b09c64 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.ml 8647 2006-03-18 15:33:09Z herbelin $ i*)
+(*i $Id: entries.ml 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Names
@@ -62,7 +62,7 @@ type definition_entry = {
   const_entry_opaque : bool;
   const_entry_boxed  : bool}
 
-type parameter_entry = types
+type parameter_entry = types*bool
 
 type constant_entry = 
   | DefinitionEntry of definition_entry
@@ -74,30 +74,23 @@ type specification_entry =
     SPEconst of constant_entry
   | SPEmind of mutual_inductive_entry
   | SPEmodule of module_entry
-  | SPEmodtype of module_type_entry
+  | SPEalias of module_path
+  | SPEmodtype of module_struct_entry
 
-and module_type_entry = 
-    MTEident of kernel_name
-  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
-  | MTEsig of mod_self_id * module_signature_entry
-  | MTEwith of module_type_entry * with_declaration
-
-and module_signature_entry = (label * specification_entry) list
+and 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
+  | MSEapply of module_struct_entry * module_struct_entry
 
 and with_declaration = 
     With_Module of identifier list * module_path
   | With_Definition of identifier list * constr
 
-and module_expr = 
-    MEident of module_path
-  | MEfunctor of mod_bound_id * module_type_entry * module_expr
-  | MEstruct of mod_self_id * module_structure
-  | MEapply of module_expr * module_expr
-
 and module_structure = (label * specification_entry) list
 
-
 and module_entry = 
-    { mod_entry_type : module_type_entry option;
-      mod_entry_expr : module_expr option}
+    { mod_entry_type : module_struct_entry option;
+      mod_entry_expr : module_struct_entry option}
+
 
diff --git a/kernel/entries.mli b/kernel/entries.mli
index b9a95d44..ed315ab8 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.mli 8647 2006-03-18 15:33:09Z herbelin $ i*)
+(*i $Id: entries.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Names
@@ -61,7 +61,7 @@ type definition_entry = {
   const_entry_opaque : bool;
   const_entry_boxed  : bool }
 
-type parameter_entry = types
+type parameter_entry = types*bool  (*inline flag*)
 
 type constant_entry = 
   | DefinitionEntry of definition_entry
@@ -73,30 +73,23 @@ type specification_entry =
     SPEconst of constant_entry
   | SPEmind of mutual_inductive_entry
   | SPEmodule of module_entry
-  | SPEmodtype of module_type_entry
+  | SPEalias of module_path
+  | SPEmodtype of module_struct_entry
 
-and module_type_entry = 
-    MTEident of kernel_name
-  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
-  | MTEsig of mod_self_id * module_signature_entry
-  | MTEwith of module_type_entry * with_declaration
-
-and module_signature_entry = (label * specification_entry) list
+and 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
+  | MSEapply of module_struct_entry * module_struct_entry
 
 and with_declaration = 
     With_Module of identifier list * module_path
   | With_Definition of identifier list * constr
 
-and module_expr = 
-    MEident of module_path
-  | MEfunctor of mod_bound_id * module_type_entry * module_expr
-  | MEstruct of mod_self_id * module_structure
-  | MEapply of module_expr * module_expr
-
 and module_structure = (label * specification_entry) list
 
-
 and module_entry = 
-    { mod_entry_type : module_type_entry option;
-      mod_entry_expr : module_expr option}
+    { mod_entry_type : module_struct_entry option;
+      mod_entry_expr : module_struct_entry option}
+
 
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 87a6e485..ad435eb5 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml 9573 2007-01-31 20:18:18Z notin $ *)
+(* $Id: environ.ml 11001 2008-05-27 16:56:07Z aspiwack $ *)
 
 open Util
 open Names
@@ -15,7 +15,6 @@ open Univ
 open Term
 open Declarations
 open Pre_env
-open Csymtable
 
 (* The type of environments. *)
 
@@ -24,6 +23,7 @@ type named_context_val = Pre_env.named_context_val
 type env = Pre_env.env
 
 let pre_env env = env
+let env_of_pre_env env = env
 
 let empty_named_context_val = empty_named_context_val
 
@@ -58,9 +58,7 @@ let push_rel = push_rel
 let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
     
 let push_rec_types (lna,typarray,_) env =
-  let ctxt =
-    array_map2_i
-      (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in
+  let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
     
 let reset_rel_context env =
@@ -85,13 +83,14 @@ let fold_rel_context f env ~init =
 (* Named context *)
 
 let named_context_of_val = fst
+let named_vals_of_val = snd
 
 (* [map_named_val f ctxt] apply [f] to the body and the type of
    each declarations.
    *** /!\ ***   [f t] should be convertible with t *)  
 let map_named_val f (ctxt,ctxtv) = 
   let ctxt =
-    List.map (fun (id,body,typ) -> (id, option_map f body, f typ)) ctxt in
+    List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in
   (ctxt,ctxtv)
 
 let empty_named_context = empty_named_context 
@@ -162,7 +161,7 @@ let add_constant kn cs env =
 (* constant_type gives the type of a constant *)
 let constant_type env kn =
   let cb = lookup_constant kn env in
-  cb.const_type  
+    cb.const_type  
 
 type const_evaluation_result = NoBody | Opaque
 
@@ -245,30 +244,6 @@ let global_vars_set env constr =
   in 
     filtrec Idset.empty constr
 
-(* like [global_vars] but don't get through evars *)
-let global_vars_set_drop_evar env constr = 
-  let fold_constr_drop_evar f acc c = match kind_of_term c with
-    | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-      | Construct _) -> acc
-    | Cast (c,_,t) -> f (f acc c) t
-    | Prod (_,t,c) -> f (f acc t) c
-    | Lambda (_,t,c) -> f (f acc t) c
-    | LetIn (_,b,t,c) -> f (f (f acc b) t) c
-    | App (c,l) -> Array.fold_left f (f acc c) l
-    | Evar (_,l) -> acc
-    | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
-    | Fix (_,(lna,tl,bl)) ->
-	let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-	  Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
-    | CoFix (_,(lna,tl,bl)) ->
-	let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-	  Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd in
-  let rec filtrec acc c =
-    let vl = vars_of_global env c in
-    let acc = List.fold_right Idset.add vl acc in
-      fold_constr_drop_evar filtrec acc c
-  in 
-    filtrec Idset.empty constr
 
 (* [keep_hyps env ids] keeps the part of the section context of [env] which 
    contains the variables of the set [ids], and recursively the variables 
@@ -299,7 +274,7 @@ let keep_hyps env needed =
 (* Modules *)
 
 let add_modtype ln mtb env = 
-  let new_modtypes = KNmap.add ln mtb env.env_globals.env_modtypes in
+  let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
   let new_globals = 
     { env.env_globals with 
 	env_modtypes = new_modtypes } in
@@ -312,14 +287,33 @@ let shallow_add_module mp mb env =
 	env_modules = new_mods } in
   { env with env_globals = new_globals }
 
+let rec scrape_alias mp env = 
+  try
+    let mp1 = MPmap.find mp env.env_globals.env_alias in
+      scrape_alias mp1 env
+  with
+      Not_found -> mp
+
 let lookup_module mp env = 
-  MPmap.find mp env.env_globals.env_modules
+  let mp = scrape_alias mp env in
+    MPmap.find mp env.env_globals.env_modules
 
 let lookup_modtype ln env = 
-  KNmap.find ln env.env_globals.env_modtypes
+  let mp = scrape_alias ln env in
+  MPmap.find mp env.env_globals.env_modtypes
 
-(*s Judgments. *)
+let register_alias mp1 mp2 env =
+  let new_alias =  MPmap.add mp1 mp2 env.env_globals.env_alias in
+  let new_globals = 
+    { env.env_globals with 
+	env_alias = new_alias } in
+    { env with env_globals = new_globals }
+
+let lookup_alias mp env =
+  MPmap.find mp env.env_globals.env_alias
 
+(*s Judgments. *)
+	
 type unsafe_judgment = { 
   uj_val : constr;
   uj_type : types }
@@ -382,15 +376,300 @@ let insert_after_hyp (ctxt,vals) id d check =
     | _, _ -> assert false
   in aux ctxt vals
 
+
 (* To be used in Logic.clear_hyps *)
-let remove_hyps ids check (ctxt, vals) =
+let remove_hyps ids check_context check_value (ctxt, vals) =
   let ctxt,vals,rmv = 
-    List.fold_right2 (fun (id,_,_ as d) v (ctxt,vals,rmv) ->
+    List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals,rmv) ->
       if List.mem id ids then 
 	(ctxt,vals,id::rmv)
       else 	  
-	let nd = check d in
-	  (nd::ctxt,v::vals,rmv))
+	let nd = check_context d in
+	let nv = check_value v in
+	  (nd::ctxt,(id',nv)::vals,rmv))
 		     ctxt vals ([],[],[])
   in ((ctxt,vals),rmv)
 
+
+
+
+
+
+(*spiwack: the following functions assemble the pieces of the retroknowledge
+   note that the "consistent" register function is available in the module
+   Safetyping, Environ only synchronizes the proactive and the reactive parts*)
+
+open Retroknowledge
+
+(* lifting of the "get" functions works also for "mem"*)
+let retroknowledge f env =
+  f env.retroknowledge
+
+let registered env field =
+    retroknowledge mem env field
+
+(* spiwack: this unregistration function is not in operation yet. It should
+            not be used *)
+(* this unregistration function assumes that no "constr" can hold two different
+   places in the retroknowledge. There is no reason why it shouldn't be true,
+   but in case someone needs it, remember to add special branches to the
+   unregister function *)
+let unregister env field =
+  match field with
+    | KInt31 (_,Int31Type) -> 
+	(*there is only one matching kind due to the fact that Environ.env
+          is abstract, and that the only function which add elements to the
+          retroknowledge is Environ.register which enforces this shape *)
+	(match retroknowledge find env field with 
+	   | Ind i31t -> let i31c = Construct (i31t, 1) in
+	     {env with retroknowledge = 
+		 remove (retroknowledge clear_info env i31c) field}
+	   | _ -> assert false)
+    |_ -> {env with retroknowledge =
+	   try 
+	     remove (retroknowledge clear_info env 
+                       (retroknowledge find env field)) field
+	   with Not_found ->
+	     retroknowledge remove env field}
+
+
+
+(* the Environ.register function syncrhonizes the proactive and reactive 
+   retroknowledge. *)
+let register =
+
+  (* subfunction used for static decompilation of int31 (after a vm_compute,
+     see pretyping/vnorm.ml for more information) *)
+  let constr_of_int31 =
+    let nth_digit_plus_one i n = (* calculates the nth (starting with 0)
+                                    digit of i and adds 1 to it 
+                                    (nth_digit_plus_one 1 3 = 2) *)
+      if (land) i ((lsl) 1 n) = 0 then
+        1
+      else
+        2
+    in
+      fun ind -> fun digit_ind -> fun tag ->
+	let array_of_int i =
+	  Array.init 31 (fun n -> mkConstruct
+			   (digit_ind, nth_digit_plus_one i (30-n)))
+	in
+	  mkApp(mkConstruct(ind, 1), array_of_int tag)
+  in
+
+  (* subfunction which adds the information bound to the constructor of
+     the int31 type to the reactive retroknowledge *)
+  let add_int31c retroknowledge c = 
+    let rk = add_vm_constant_static_info retroknowledge c 
+                                         Cbytegen.compile_structured_int31
+    in
+    add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation
+  in
+
+  (* subfunction which adds the compiling information of an
+     int31 operation which has a specific vm instruction (associates
+     it to the name of the coq definition in the reactive retroknowledge) *)
+  let add_int31_op retroknowledge v n op kn =
+    add_vm_compiling_info retroknowledge v (Cbytegen.op_compilation n op kn)
+  in
+
+fun env field value ->
+  (* subfunction which shortens the (very often use) registration of binary
+     operators to the reactive retroknowledge. *)
+  let add_int31_binop_from_const op =
+    match value with
+      | Const kn ->  retroknowledge add_int31_op env value 2 
+	                               op kn
+      | _ -> anomaly "Environ.register: should be a constant"
+  in
+  let add_int31_unop_from_const op =
+    match value with
+      | Const kn ->  retroknowledge add_int31_op env value 1
+	                               op kn
+      | _ -> anomaly "Environ.register: should be a constant"
+  in
+  (* subfunction which completes the function constr_of_int31 above
+     by performing the actual retroknowledge operations *)
+  let add_int31_decompilation_from_type rk = 
+    (* invariant : the type of bits is registered, otherwise the function 
+       would raise Not_found. The invariant is enforced in safe_typing.ml *)
+    match field with
+      | KInt31 (grp, Int31Type) -> 
+	  (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with
+	    | Ind i31bit_type ->  
+		(match value with 
+		  | Ind i31t -> 
+		      Retroknowledge.add_vm_decompile_constant_info rk
+		               value (constr_of_int31 i31t i31bit_type)
+		  | _ -> anomaly "Environ.register: should be an inductive type")
+	    | _ -> anomaly "Environ.register: Int31Bits should be an inductive type")
+      | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field"
+  in
+  {env with retroknowledge = 
+  let retroknowledge_with_reactive_info = 
+  match field with
+    | KInt31 (_, Int31Type) -> 
+        let i31c = match value with
+                     | Ind i31t -> (Construct (i31t, 1))
+		     | _ -> anomaly "Environ.register: should be an inductive type"
+	in
+	add_int31_decompilation_from_type 
+	  (add_vm_before_match_info 
+	     (retroknowledge add_int31c env i31c) 
+	     value Cbytegen.int31_escape_before_match)
+    | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31
+    | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31
+    | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31
+    | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31
+    | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31
+    | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const 
+	                                           Cbytecodes.Ksubcarrycint31
+    | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31
+    | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31
+    | KInt31 (_, Int31Div21) -> (* this is a ternary operation *)
+                                (match value with
+				 | Const kn ->
+				     retroknowledge add_int31_op env value 3 
+	                               Cbytecodes.Kdiv21int31 kn
+				 | _ -> anomaly "Environ.register: should be a constant")
+    | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31
+    | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *)
+                                (match value with
+				 | Const kn ->
+				     retroknowledge add_int31_op env value 3 
+	                               Cbytecodes.Kaddmuldivint31 kn
+				 | _ -> anomaly "Environ.register: should be a constant")
+    | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31
+    | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31
+    | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 
+    | _ -> env.retroknowledge 
+  in
+  Retroknowledge.add_field retroknowledge_with_reactive_info field value
+  }
+
+
+(**************************************************************)
+(* spiwack: the following definitions are used by the function 
+   [assumptions] which gives as an output the set of all
+   axioms and sections variables on which a given term depends
+   in a context (expectingly the Global context) *)
+
+type context_object =
+  | Variable of identifier (* A section variable or a Let definition *)
+  | Axiom of constant      (* An axiom or a constant. *)
+
+
+(* Defines a set of [assumption] *)
+module OrderedContextObject = 
+struct 
+  type t = context_object
+  let compare x y = 
+      match x , y with
+      | Variable i1 , Variable i2 -> id_ord i1 i2
+      | Axiom k1 , Axiom k2 -> Pervasives.compare k1 k2
+	          (* spiwack: it would probably be cleaner
+		     to provide a [kn_ord] function *)
+      | Variable _ , Axiom _ -> -1
+      | Axiom _ , Variable _ -> 1
+end
+
+module ContextObjectSet = Set.Make (OrderedContextObject)
+module ContextObjectMap = Map.Make (OrderedContextObject)
+
+
+let assumptions (* t env *) =   
+  (* Infix definition for chaining function that accumulate
+     on a and a ContextObjectSet, ContextObjectMap.  *)
+  let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in
+  (* This function eases memoization, by checking if an object is already
+     stored before trying and applying a function. 
+     If the object is there, the function is not fired (we are in a 
+     particular case where memoized object don't need a treatment at all).
+     If the object isn't there, it is stored and the function is fired*)
+  let try_and_go o f s m =
+    if ContextObjectSet.mem o s then
+      (s,m)
+    else
+      f (ContextObjectSet.add o s) m
+  in
+  let identity2 s m = (s,m) in
+  (* Goes recursively into the term to see if it depends on assumptions
+    the 3 important cases are : - Const _ where we need to first unfold
+    the constant and return the needed assumptions of its body in the 
+    environment,
+                                - Rel _ which means the term is a variable
+    which has been bound earlier by a Lambda or a Prod (returns [] ),
+                                - Var _ which means that the term refers
+    to a section variable or a "Let" definition, in the former it is
+    an assumption of [t], in the latter is must be unfolded like a Const.
+    The other cases are straightforward recursion.
+    Calls to the environment are memoized, thus avoiding to explore
+    the DAG of the environment as if it was a tree (can cause
+    exponential behavior and prevent the algorithm from terminating
+    in reasonable time). [s] is a set of [context_object], representing
+    the object already visited.*)
+  let rec aux t env s acc =
+    match kind_of_term t with
+    | Var id -> aux_memoize_id id env s acc
+    | Meta _ | Evar _ -> 
+	Util.anomaly "Environ.assumption: does not expect a meta or an evar"
+    | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> 
+                           ((aux e1 env)**(aux e2 env)) s acc
+    | LetIn (_,e1,e2,e3) -> ((aux e1 env)**
+                             (aux e2 env)**
+                             (aux e3 env))
+	                     s acc 
+    | App (e1, e_array) -> ((aux e1 env)**
+			    (Array.fold_right 
+			       (fun e f -> (aux e env)**f)
+                               e_array identity2))
+	                   s acc
+    | Case (_,e1,e2,e_array) -> ((aux e1 env)**
+                                 (aux e2 env)**
+				 (Array.fold_right 
+				    (fun e f -> (aux e env)**f)
+                                    e_array identity2))
+	                        s acc
+    | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) ->
+                  ((Array.fold_right 
+		      (fun e f -> (aux e env)**f)
+                      e1_array identity2) **
+                   (Array.fold_right 
+		      (fun e f -> (aux e env)**f)
+                      e2_array identity2))
+		     s acc
+    | Const kn -> aux_memoize_kn kn env s acc
+    | _ -> (s,acc) (* closed atomic types + rel *)
+
+  and add_id id env s acc =
+    (* a Var can be either a variable, or a "Let" definition.*)
+    match lookup_named id env with
+    | (_,None,t) ->
+        (s,ContextObjectMap.add (Variable id) t acc)
+    | (_,Some bdy,_) -> aux bdy env s acc
+
+  and aux_memoize_id id env =
+    try_and_go (Variable id) (add_id id env)
+
+  and add_kn kn env s acc =
+    let cb = lookup_constant kn env in
+    match cb.Declarations.const_body with
+    | None -> 
+	let ctype = 
+	  match cb.Declarations.const_type with
+	  | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level)
+	  | NonPolymorphicType t -> t
+	in
+	(s,ContextObjectMap.add (Axiom kn) ctype acc)
+    | Some body -> aux (Declarations.force body) env s acc
+
+  and aux_memoize_kn kn env =
+    try_and_go (Axiom kn) (add_kn kn env)
+ in
+ fun t env ->
+   snd (aux t env (ContextObjectSet.empty) (ContextObjectMap.empty))
+    
+(* /spiwack *)
+
+
+
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 478357d7..30f555a4 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: environ.mli 9573 2007-01-31 20:18:18Z notin $ i*)
+(*i $Id: environ.mli 11001 2008-05-27 16:56:07Z aspiwack $ i*)
 
 (*i*)
 open Names
@@ -35,6 +35,7 @@ open Sign
 
 type env
 val pre_env : env -> Pre_env.env
+val env_of_pre_env : Pre_env.env -> env
 
 type named_context_val
 val eq_named_context_val : named_context_val -> named_context_val -> bool
@@ -72,6 +73,7 @@ val fold_rel_context :
 (* 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
 val val_of_named_context : named_context -> named_context_val
 val empty_named_context_val : named_context_val
 
@@ -145,13 +147,17 @@ val scrape_mind : env -> mutual_inductive -> mutual_inductive
 
 (************************************************************************)
 (*s Modules *)
-val add_modtype : kernel_name -> module_type_body -> env -> env
+val add_modtype : module_path -> module_type_body -> env -> env
 
 (* [shallow_add_module] does not add module components *)
 val shallow_add_module : module_path -> module_body -> env -> env
 
 val lookup_module : module_path -> env -> module_body
-val lookup_modtype : kernel_name -> env -> module_type_body
+val lookup_modtype : module_path -> env -> module_type_body
+
+val register_alias : module_path -> module_path -> env -> env
+val lookup_alias : module_path -> env -> module_path
+val scrape_alias : module_path -> env -> module_path
 
 (************************************************************************)
 (*s Universe constraints *)
@@ -165,7 +171,6 @@ val set_engagement : engagement -> env -> env
 (* [global_vars_set env c] returns the list of [id]'s occurring as
    [VAR id] in [c] *)
 val global_vars_set : env -> constr -> Idset.t
-val global_vars_set_drop_evar : env -> constr -> Idset.t
 (* the constr must be an atomic construction *)
 val vars_of_global : env -> constr -> identifier list
 
@@ -217,5 +222,35 @@ val insert_after_hyp : named_context_val -> variable ->
   named_declaration -> 
     (named_context -> unit) -> named_context_val
 
-val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> named_context_val -> named_context_val * identifier list
+val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val * identifier list
+
+
+(* spiwack: functions manipulating the retroknowledge *)
+open Retroknowledge
+
+val retroknowledge : (retroknowledge->'a) -> env -> 'a
+
+val registered : env -> field -> bool
+
+val unregister : env -> field -> env
+
+val register : env -> field -> Retroknowledge.entry -> env
+
+
+
+(******************************************************************)
+(* spiwack: a few declarations for the "Print Assumption" command *)
+
+type context_object =
+  | Variable of identifier (* A section variable or a Let definition *)
+  | Axiom of constant      (* An axiom or a constant. *)
+
+(* AssumptionSet.t is a set of [assumption] *)
+module OrderedContextObject :  Set.OrderedType with type t = context_object
+module ContextObjectMap : Map.S with type key = context_object
+
+(* collects all the assumptions on which a term relies (together with
+   their type *)
+val assumptions : constr -> env -> Term.types ContextObjectMap.t
+
 
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index a6fd6d04..7cedebbd 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml 10297 2007-11-07 11:05:53Z barras $ *)
+(* $Id: indtypes.ml 10920 2008-05-12 10:19:32Z herbelin $ *)
 
 open Util
 open Names
@@ -39,10 +39,10 @@ let is_constructor_head t =
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * constr * constr
+  | NotConstructor of env * identifier * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
   | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier * identifier
+  | SameNamesConstructors of identifier
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
@@ -54,12 +54,12 @@ exception InductiveError of inductive_error
    of names. The name [id] is the name of the current inductive type, used
    when reporting the error. *)
 
-let check_constructors_names id =
+let check_constructors_names =
   let rec check idset = function
     | [] -> idset
     | c::cl -> 
 	if Idset.mem c idset then 
-	  raise (InductiveError (SameNamesConstructors (id,c)))
+	  raise (InductiveError (SameNamesConstructors c))
 	else
 	  check (Idset.add c idset) cl
   in
@@ -78,7 +78,7 @@ let mind_check_names mie =
 	if Idset.mem id indset then
 	  raise (InductiveError (SameNamesTypes id))
 	else
-	  let cstset' = check_constructors_names id cstset cl in
+	  let cstset' = check_constructors_names cstset cl in
 	  check (Idset.add id indset) cstset' inds
   in
   check Idset.empty Idset.empty mie.mind_entry_inds
@@ -100,7 +100,7 @@ let mind_check_arities env mie =
 
 (* Typing the arities and constructor types *)
 
-let is_logic_type t = (t.utj_type = mk_Prop)
+let is_logic_type t = (t.utj_type = prop_sort)
 
 (* [infos] is a sequence of pair [islogic,issmall] for each type in
    the product of a constructor or arity *)
@@ -128,7 +128,7 @@ let rec infos_and_sort env t =
 	let small = Term.is_small varj.utj_type in
 	(logic,small) :: (infos_and_sort env1 c2)
     | _ when is_constructor_head t -> []
-    | _ -> anomaly "infos_and_sort: not a positive constructor"
+    | _ -> (* don't fail if not positive, it is tested later *) []
 
 let small_unit constrsinfos =
   let issmall = List.for_all is_small constrsinfos 
@@ -157,7 +157,7 @@ let small_unit constrsinfos =
 
 let extract_level (_,_,_,lc,lev) =
   (* Enforce that the level is not in Prop if more than two constructors *)
-  if Array.length lc >= 2 then sup base_univ lev else lev
+  if Array.length lc >= 2 then sup type0_univ lev else lev
 
 let inductive_levels arities inds =
   let levels = Array.map pi3 arities in
@@ -262,7 +262,7 @@ let typecheck_inductive env mie =
 	  Inl (info,full_arity,s), enforce_geq u lev cst
       | Prop Pos when engagement env <> Some ImpredicativeSet ->
 	  (* Predicative set: check that the content is indeed predicative *)
-	  if not (is_empty_univ lev) & not (is_base_univ lev) then
+	  if not (is_type0m_univ lev) & not (is_type0_univ lev) then
 	    error "Large non-propositional inductive types must be in Type";
 	  Inl (info,full_arity,s), cst
       | Prop _ ->
@@ -290,7 +290,7 @@ exception IllFormedInd of ill_formed_ind
 
 let mind_extract_params = decompose_prod_n_assum
 
-let explain_ind_err ntyp env0 nbpar c err = 
+let explain_ind_err id ntyp env0 nbpar c nargs err = 
   let (lpar,c') = mind_extract_params nbpar c in
   let env = push_rel_context lpar env0 in
   match err with
@@ -301,7 +301,7 @@ let explain_ind_err ntyp env0 nbpar c err =
 		 (NotEnoughArgs (env,c',mkRel (kt+nbpar))))
     | LocalNotConstructor ->
 	raise (InductiveError 
-		 (NotConstructor (env,c',mkRel (ntyp+nbpar))))
+		 (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs)))
     | LocalNonPar (n,l) ->
 	raise (InductiveError 
 		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
@@ -386,7 +386,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
     push_rel (Anonymous,None,
               hnf_prod_applist env (type_of_inductive env specif) lpar) env in
   let ra_env' = 
-    (Imbr mi,Rtree.mk_param 0) ::
+    (Imbr mi,(Rtree.mk_rec_calls 1).(0)) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
   (* New index of the inductive types *)
   let newidx = n + auxntyp in
@@ -397,40 +397,40 @@ 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 indlc =
+let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
   let lparams = rel_context_length hyps in
   let nmr = rel_context_nhyps hyps in
   (* check the inductive types occur positively in [c] *)
   let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = 
     let x,largs = decompose_app (whd_betadeltaiota env c) in
-    match kind_of_term x with
-      | Prod (na,b,d) ->
-	  assert (largs = []);
-          (match weaker_noccur_between env n ntypes b with
-              None -> failwith_non_pos_list n ntypes [b]
-            | Some b ->
-	        check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
-      | Rel k ->
-           (try let (ra,rarg) = List.nth ra_env (k-1) in 
-		let nmr1 =
-	       (match ra with
-                 Mrec _ -> compute_rec_par ienv hyps nmr largs
-		  |  _ -> nmr)
-		in 
-		  if not (List.for_all (noccur_between n ntypes) largs)
-	          then failwith_non_pos_list n ntypes largs
-		  else (nmr1,rarg)
-            with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
-      | Ind ind_kn ->
-          (* If the inductive type being defined appears in a
-             parameter, then we have an imbricated type *)
-          if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
-          else check_positive_imbr ienv nmr (ind_kn, largs)
-      | err -> 
-	  if noccur_between n ntypes x &&
-             List.for_all (noccur_between n ntypes) largs 
-	  then (nmr,mk_norec)
-	  else failwith_non_pos_list n ntypes (x::largs)
+      match kind_of_term x with
+	| Prod (na,b,d) ->
+	    assert (largs = []);
+            (match weaker_noccur_between env n ntypes b with
+		None -> failwith_non_pos_list n ntypes [b]
+              | Some b ->
+	          check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
+	| Rel k ->
+            (try let (ra,rarg) = List.nth ra_env (k-1) in 
+	    let nmr1 =
+	      (match ra with
+                  Mrec _ -> compute_rec_par ienv hyps nmr largs
+		|  _ -> nmr)
+	    in 
+	      if not (List.for_all (noccur_between n ntypes) largs)
+	      then failwith_non_pos_list n ntypes largs
+	      else (nmr1,rarg)
+              with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
+	| Ind ind_kn ->
+            (* If the inductive type being defined appears in a
+               parameter, then we have an imbricated type *)
+            if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
+            else check_positive_imbr ienv nmr (ind_kn, largs)
+	| err -> 
+	    if noccur_between n ntypes x &&
+              List.for_all (noccur_between n ntypes) largs 
+	    then (nmr,mk_norec)
+	    else failwith_non_pos_list n ntypes (x::largs)
 
   (* accesses to the environment are not factorised, but is it worth? *)
   and check_positive_imbr (env,n,ntypes,ra_env as ienv) nmr (mi, largs) =
@@ -439,70 +439,70 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
     let (lpar,auxlargs) =
       try list_chop auxnpar largs 
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
-    (* If the inductive appears in the args (non params) then the
-       definition is not positive. *)
-    if not (List.for_all (noccur_between n ntypes) auxlargs) then
-      raise (IllFormedInd (LocalNonPos n));
-    (* We do not deal with imbricated mutual inductive types *)
-    let auxntyp = mib.mind_ntypes in 
-    if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
-    (* The nested inductive type with parameters removed *)
-    let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
-    (* Extends the environment with a variable corresponding to
-       the inductive def *)
-    let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
-    (* Parameters expressed in env' *)
-    let lpar' = List.map (lift auxntyp) lpar in
-    let irecargs_nmr = 
-      (* fails if the inductive type occurs non positively *)
-      (* when substituted *) 
-      Array.map 
-	(function c -> 
-	  let c' = hnf_prod_applist env' c lpar' in 
-	  check_constructors ienv' false nmr c') 
-	auxlcvect
-    in
-    let irecargs = Array.map snd irecargs_nmr
-    and nmr' = array_min nmr irecargs_nmr
-    in 
-    (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0))
-  
+      (* If the inductive appears in the args (non params) then the
+	 definition is not positive. *)
+      if not (List.for_all (noccur_between n ntypes) auxlargs) then
+	raise (IllFormedInd (LocalNonPos n));
+      (* We do not deal with imbricated mutual inductive types *)
+      let auxntyp = mib.mind_ntypes in 
+	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+	(* The nested inductive type with parameters removed *)
+	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+	  (* Extends the environment with a variable corresponding to
+	     the inductive def *)
+	let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
+	  (* Parameters expressed in env' *)
+	let lpar' = List.map (lift auxntyp) lpar in
+	let irecargs_nmr = 
+	  (* fails if the inductive type occurs non positively *)
+	  (* when substituted *) 
+	  Array.map 
+	    (function c -> 
+	      let c' = hnf_prod_applist env' c lpar' in 
+		check_constructors ienv' false nmr c') 
+	    auxlcvect
+	in
+	let irecargs = Array.map snd irecargs_nmr
+	and nmr' = array_min nmr irecargs_nmr
+	in 
+	  (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0))
+	    
   (* check the inductive types occur positively in the products of C, if
      check_head=true, also check the head corresponds to a constructor of
      the ith type *) 
-
+	    
   and check_constructors ienv check_head nmr c = 
     let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = 
       let x,largs = decompose_app (whd_betadeltaiota env c) in
-      match kind_of_term x with
-
-        | Prod (na,b,d) -> 
-	    assert (largs = []);
-            let nmr',recarg = check_pos ienv nmr b in 
-            let ienv' = ienv_push_var ienv (na,b,mk_norec) in
-	    check_constr_rec ienv' nmr' (recarg::lrec) d
-
-	| hd ->
-	    if check_head then
-	      if hd = Rel (n+ntypes-i-1) then
-		check_correct_par ienv hyps (ntypes-i) largs
+	match kind_of_term x with
+
+          | Prod (na,b,d) -> 
+	      assert (largs = []);
+              let nmr',recarg = check_pos ienv nmr b in 
+              let ienv' = ienv_push_var ienv (na,b,mk_norec) in
+		check_constr_rec ienv' nmr' (recarg::lrec) d
+		  
+	  | hd ->
+	      if check_head then
+		if hd = Rel (n+ntypes-i-1) then
+		  check_correct_par ienv hyps (ntypes-i) largs
+		else
+		  raise (IllFormedInd LocalNotConstructor)
 	      else
-		raise (IllFormedInd LocalNotConstructor)
-	    else
-	      if not (List.for_all (noccur_between n ntypes) largs)
+		if not (List.for_all (noccur_between n ntypes) largs)
               then raise (IllFormedInd (LocalNonPos n));
-	    (nmr,List.rev lrec)
+	      (nmr,List.rev lrec)
     in check_constr_rec ienv nmr [] c
   in
   let irecargs_nmr =
-     Array.map
-      (fun c ->
+    array_map2
+      (fun id c ->
         let _,rawc = mind_extract_params lparams c in
-        try
-	  check_constructors ienv true nmr rawc
-        with IllFormedInd err -> 
-	  explain_ind_err (ntypes-i) env lparams c err)
-      indlc
+          try
+	    check_constructors ienv true nmr rawc
+          with IllFormedInd err -> 
+	    explain_ind_err id (ntypes-i) env lparams c nargs err)
+      (Array.of_list lcnames) indlc
   in
   let irecargs = Array.map snd irecargs_nmr
   and nmr' = array_min nmr irecargs_nmr
@@ -510,15 +510,16 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
 
 let check_positivity env_ar params inds =
   let ntypes = Array.length inds in
-  let lra_ind =
-    List.rev (list_tabulate (fun j -> (Mrec j, Rtree.mk_param j)) ntypes) in
+  let rc = Array.mapi (fun j t -> (Mrec 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
-  let check_one i (_,_,lc,_) =
+  let check_one i (_,lcnames,lc,(sign,_)) =
     let ra_env =
       list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
-    check_positivity_one ienv params i lc 
+    let nargs = rel_context_nhyps sign - nmr in
+    check_positivity_one ienv params i nargs lcnames lc 
   in
   let irecargs_nmr = Array.mapi check_one inds in 
   let irecargs = Array.map snd irecargs_nmr
@@ -589,61 +590,61 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
     let consnrealargs =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
-    (* Elimination sorts *)
+      (* Elimination sorts *)
     let arkind,kelim = match ar_kind with
-    | Inr (param_levels,lev) ->
-	Polymorphic {
-	  poly_param_levels = param_levels;
-	  poly_level = lev; 
-	}, all_sorts
-    | Inl ((issmall,isunit),ar,s) ->
-	let isunit = isunit && ntypes = 1 && not (is_recursive recargs.(0)) in
-	let kelim = allowed_sorts issmall isunit s in
-	Monomorphic {
-	  mind_user_arity = ar;
-	  mind_sort = s; 
-	}, kelim in
+      | Inr (param_levels,lev) ->
+	  Polymorphic {
+	      poly_param_levels = param_levels;
+	      poly_level = lev; 
+	    }, all_sorts
+      | Inl ((issmall,isunit),ar,s) ->
+	  let isunit = isunit && ntypes = 1 && not (is_recursive recargs.(0)) in
+	  let kelim = allowed_sorts issmall isunit s in
+	    Monomorphic {
+		mind_user_arity = ar;
+		mind_sort = s; 
+	      }, kelim in
     let nconst, nblock = ref 0, ref 0 in 
     let transf num =
       let arity = List.length (dest_subterms recarg).(num) in
-      if arity = 0 then 
-	let p  = (!nconst, 0) in
-	incr nconst; p
-      else 
-	let p = (!nblock + 1, arity) in
-	incr nblock; p
-     (* les tag des constructeur constant commence a 0,
-	les tag des constructeur non constant a 1 (0 => accumulator) *)
+	if arity = 0 then 
+	  let p  = (!nconst, 0) in
+	    incr nconst; p
+	else 
+	  let p = (!nblock + 1, arity) in
+	    incr nblock; p
+	      (* les tag des constructeur constant commence a 0,
+		 les tag des constructeur non constant a 1 (0 => accumulator) *)
     in 
     let rtbl = Array.init (List.length cnames) transf in
-    (* Build the inductive packet *)
-    { mind_typename = id;
-      mind_arity = arkind;
-      mind_arity_ctxt = ar_sign;
-      mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
-      mind_kelim = kelim;
-      mind_consnames = Array.of_list cnames;
-      mind_consnrealdecls = consnrealargs;
-      mind_user_lc = lc;
-      mind_nf_lc = nf_lc;
-      mind_recargs = recarg;
-      mind_nb_constant = !nconst;
-      mind_nb_args = !nblock;
-      mind_reloc_tbl = rtbl;
-    } in
+      (* Build the inductive packet *)
+      { mind_typename = id;
+	mind_arity = arkind;
+	mind_arity_ctxt = ar_sign;
+	mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
+	mind_kelim = kelim;
+	mind_consnames = Array.of_list cnames;
+	mind_consnrealdecls = consnrealargs;
+	mind_user_lc = lc;
+	mind_nf_lc = nf_lc;
+	mind_recargs = recarg;
+	mind_nb_constant = !nconst;
+	mind_nb_args = !nblock;
+	mind_reloc_tbl = rtbl;
+      } in
   let packets = array_map2 build_one_packet inds recargs in
-  (* Build the mutual inductive *)
-  { mind_record = isrecord;
-    mind_ntypes = ntypes;
-    mind_finite = isfinite;
-    mind_hyps = hyps;
-    mind_nparams = nparamargs;
-    mind_nparams_rec = nmr;  
-    mind_params_ctxt = params;
-    mind_packets = packets;
-    mind_constraints = cst;
-    mind_equiv = None;
-  }
+    (* Build the mutual inductive *)
+    { mind_record = isrecord;
+      mind_ntypes = ntypes;
+      mind_finite = isfinite;
+      mind_hyps = hyps;
+      mind_nparams = nparamargs;
+      mind_nparams_rec = nmr;  
+      mind_params_ctxt = params;
+      mind_packets = packets;
+      mind_constraints = cst;
+      mind_equiv = None;
+    }
 
 (************************************************************************)
 (************************************************************************)
@@ -654,5 +655,5 @@ let check_inductive env mie =
   (* Then check positivity conditions *)
   let (nmr,recargs) = check_positivity 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
+    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 67d11f56..0477df82 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
+(*i $Id: indtypes.mli 10425 2008-01-05 17:04:16Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -26,10 +26,10 @@ open Typeops
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * constr * constr
+  | NotConstructor of env * identifier * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
   | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier * identifier
+  | SameNamesConstructors of identifier
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 00901686..9415941d 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml 10173 2007-10-04 13:02:56Z herbelin $ *)
+(* $Id: inductive.ml 10920 2008-05-12 10:19:32Z herbelin $ *)
 
 open Util
 open Names
@@ -83,7 +83,7 @@ let instantiate_params full t args sign =
 let instantiate_partial_params = instantiate_params false
 
 let full_inductive_instantiate mib params sign =
-  let dummy = mk_Prop in
+  let dummy = prop_sort in
   let t = mkArity (sign,dummy) in
   fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
 
@@ -124,8 +124,8 @@ Remark: Set (predicative) is encoded as Type(0)
 
 let sort_as_univ = function
 | Type u -> u
-| Prop Null -> neutral_univ
-| Prop Pos -> base_univ
+| Prop Null -> type0m_univ
+| Prop Pos -> type0_univ
 
 let cons_subst u su subst =
   try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
@@ -179,9 +179,12 @@ let instantiate_universes env ctx ar argsorts =
   let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in
   let level = subst_large_constraints subst ar.poly_level in
   ctx,
-  if is_empty_univ level then mk_Prop
-  else if is_base_univ level then mk_Set
-  else Type level
+  (* Singleton type not containing types are interpretable in Prop *)
+  if is_type0m_univ level then prop_sort
+  (* Non singleton type not containing types are interpretable in Set *)
+  else if is_type0_univ level then set_sort
+  (* This is a Type with constraints *)
+ else Type level
 
 let type_of_inductive_knowing_parameters env mip paramtyps =
   match mip.mind_arity with
@@ -201,11 +204,11 @@ let type_of_inductive env (_,mip) =
 
 let cumulate_constructor_univ u = function
   | Prop Null -> u
-  | Prop Pos -> sup base_univ u
+  | Prop Pos -> sup type0_univ u
   | Type u' -> sup u u'
 
 let max_inductive_sort =
-  Array.fold_left cumulate_constructor_univ neutral_univ
+  Array.fold_left cumulate_constructor_univ type0m_univ
 
 (************************************************************************)
 (* Type of a constructor *)
@@ -425,8 +428,8 @@ type subterm_spec =
   | Not_subterm
 
 let spec_of_tree t =
-  if t=mk_norec then Not_subterm else Subterm(Strict,t)
-
+  if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t)
+ 
 let subterm_spec_glb =
   let glb2 s1 s2 =
     match s1,s2 with
@@ -435,7 +438,7 @@ let subterm_spec_glb =
       | Not_subterm, _ -> Not_subterm
       | _, Not_subterm -> Not_subterm
       | Subterm (a1,t1), Subterm (a2,t2) ->
-          if t1=t2 then Subterm (size_glb a1 a2, t1)
+          if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1)
           (* branches do not return objects with same spec *)
           else Not_subterm in
   Array.fold_left glb2 Dead_code
@@ -653,7 +656,7 @@ let check_one_fix renv recpos def =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
-      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
+      let (f,l) = decompose_app (whd_betaiotazeta t) in
       match kind_of_term f with
         | Rel p -> 
             (* Test if [p] is a fixpoint (recursive call) *) 
@@ -666,12 +669,10 @@ let check_one_fix renv recpos def =
 	        let np = recpos.(glob) in
                 if List.length l <= np then error_partial_apply renv glob
                 else
-	          match list_chop np l with
-		      (la,(z::lrest)) -> 
-                        (* Check the decreasing arg is smaller *)
-	                if not (check_is_subterm renv z) then
-                          error_illegal_rec_call renv glob z
-	            | _ -> assert false
+                  (* 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
               end
             else
               begin
@@ -779,6 +780,8 @@ let check_one_fix renv recpos def =
   in
   check_rec_call renv def
 
+let judgment_of_fixpoint (_, types, bodies) =
+  array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   let nbfix = Array.length bodies in 
@@ -790,8 +793,9 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
     or bodynum >= nbfix
   then anomaly "Ill-formed fix term";
   let fixenv = push_rec_types recdef env in
+  let vdefj = judgment_of_fixpoint recdef in
   let raise_err env i err =
-    error_ill_formed_rec_body env err names i in
+    error_ill_formed_rec_body env err names i fixenv vdefj in
   (* Check the i-th definition with recarg k *)
   let find_ind i k def = 
     (* check fi does not appear in the k+1 first abstractions, 
@@ -817,14 +821,15 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   (Array.map fst rv, Array.map snd rv)
 
 
-let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) =
+let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
   let (minds, rdef) = inductive_of_mutfix env fix in
   for i = 0 to Array.length bodies - 1 do
     let (fenv,body) = rdef.(i) in
     let renv = make_renv fenv minds nvect.(i) minds.(i) in
     try check_one_fix renv nvect body
     with FixGuardError (fixenv,err) ->
-      error_ill_formed_rec_body fixenv err names i
+      error_ill_formed_rec_body fixenv err names i 
+	(push_rec_types recdef env) (judgment_of_fixpoint recdef)
   done
 
 (*
@@ -935,5 +940,6 @@ let check_cofix env (bodynum,(names,types,bodies as recdef)) =
     let fixenv = push_rec_types recdef env in
     try check_one_cofix fixenv nbfix bodies.(i) types.(i)
     with CoFixGuardError (errenv,err) -> 
-      error_ill_formed_rec_body errenv err names i
+      error_ill_formed_rec_body errenv err names i 
+	fixenv (judgment_of_fixpoint recdef)
   done
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 58343dab..c2c38d8d 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli 9421 2006-12-08 16:00:53Z barras $ i*)
+(*i $Id: inductive.mli 9420 2006-12-08 15:34:09Z barras $ i*)
 
 (*i*)
 open Names
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index 2942e101..ab4b8e47 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: mod_subst.ml 9874 2007-06-04 13:46:11Z soubiran $ *)
+(* $Id: mod_subst.ml 10849 2008-04-25 15:55:16Z soubiran $ *)
 
 open Pp
 open Util
@@ -27,11 +27,15 @@ let apply_opt_resolver resolve kn =
   | Some resolve ->
      try List.assoc kn resolve with Not_found -> None
 
-type substitution_domain = MSI of mod_self_id | MBI of mod_bound_id
+type substitution_domain = 
+    MSI of mod_self_id 
+  | MBI of mod_bound_id
+  | MPI of module_path
 
 let string_of_subst_domain = function
    MSI msid -> debug_string_of_msid msid
  | MBI mbid -> debug_string_of_mbid mbid
+ | MPI mp -> string_of_mp mp
 
 module Umap = Map.Make(struct 
 			 type t = substitution_domain
@@ -46,9 +50,13 @@ let add_msid msid mp =
   Umap.add (MSI msid) (mp,None)
 let add_mbid mbid mp resolve =
   Umap.add (MBI mbid) (mp,resolve)
+let add_mp mp1 mp2  =
+  Umap.add (MPI mp1) (mp2,None)
+
 
 let map_msid msid mp = add_msid msid mp empty_subst
 let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst
+let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst
 
 let list_contents sub = 
   let one_pair uid (mp,_) l =
@@ -66,6 +74,7 @@ let debug_pr_subst sub =
   in
     str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
 
+
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
@@ -74,13 +83,21 @@ let subst_mp0 sub mp = (* 's like subst *)
          mp',resolve
     | MPbound bid ->
         let mp',resolve = Umap.find (MBI bid) sub in
-         mp',resolve
-    | MPdot (mp1,l) -> 
-	let mp1',resolve = aux mp1 in
-	 MPdot (mp1',l),resolve
+          mp',resolve
+    | MPdot (mp1,l) as mp2 ->
+	begin
+	  try  
+	    let mp',resolve = Umap.find (MPI mp2) sub in
+              mp',resolve
+	  with Not_found ->    
+	    let mp1',resolve = aux mp1 in
+	      MPdot (mp1',l),resolve
+	end
     | _ -> raise Not_found
  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
@@ -130,6 +147,7 @@ let subst_evaluable_reference subst = function
   | 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
@@ -201,7 +219,6 @@ let rec map_kn f f' c =
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-
 let subst_mps sub = 
   map_kn (subst_kn0 sub) (subst_con0 sub)
 
@@ -223,60 +240,220 @@ let replace_mp_in_con mpfrom mpto kn =
 exception BothSubstitutionsAreIdentitySubstitutions
 exception ChangeDomain of resolver
 
-let join (subst1 : substitution) (subst2 : substitution) = 
+let join (subst1 : substitution) (subst2 : substitution) =
   let apply_subst (sub : substitution) key (mp,resolve) =
-   let mp',resolve' =
-     match subst_mp0 sub mp with
-	 None -> mp, None
-       | Some (mp',resolve') -> mp',resolve' in
-   let resolve'' : resolver option =
-     try
-       let res =
-	 match resolve with
-             Some res -> res
-	   | None ->
-               match resolve' with
-		   None -> raise BothSubstitutionsAreIdentitySubstitutions
-		 | Some res -> raise (ChangeDomain res)
-       in
-	 Some
-	   (List.map
-              (fun (kn,topt) ->
-		 kn,
-		 match topt with
-		     None ->
-		       (match key with
-			    MSI msid ->
-			      let kn' = replace_mp_in_con (MPself msid) mp kn in
-				apply_opt_resolver resolve' kn'
-			  | MBI mbid ->
-			      let kn' = replace_mp_in_con (MPbound mbid) mp kn in
-				apply_opt_resolver resolve' kn')
-		   | Some t -> Some (subst_mps sub t)) res)
-     with
-	 BothSubstitutionsAreIdentitySubstitutions -> None
-       | ChangeDomain res ->
-	   let rec changeDom = function
-	     | [] -> []
-	     | (kn,topt)::r ->
-		 let key' =
-		   match key with
-                       MSI msid -> MPself msid
-                     | MBI mbid -> MPbound mbid in
-		 let kn' = replace_mp_in_con mp key' kn in
-		   if kn==kn' then
-		     (*the key does not appear in mp, we remove it
-		       from the resolver that we are building*)
-		     changeDom r
-		   else
-		     (kn',topt)::(changeDom r)
-	   in
-	     Some (changeDom res)
-   in
-     mp',resolve'' in
+    let mp',resolve' =
+      match subst_mp0 sub mp with
+	  None -> mp, None
+	| Some (mp',resolve') -> mp',resolve' in
+    let resolve'' : resolver option =
+      try
+	let res =
+	  match resolve with
+              Some res -> res
+	    | None ->
+		match resolve' with
+		    None -> raise BothSubstitutionsAreIdentitySubstitutions
+		  | Some res -> raise (ChangeDomain res)
+	in
+	  Some
+	    (List.map
+               (fun (kn,topt) ->
+		  kn,
+		  match topt with
+		      None ->
+			(match key with
+			     MSI msid ->
+			       let kn' = replace_mp_in_con (MPself msid) mp kn in
+				 apply_opt_resolver resolve' kn'
+			   | MBI mbid ->
+			       let kn' = replace_mp_in_con (MPbound mbid) mp kn in
+				 apply_opt_resolver resolve' kn'
+			   | MPI mp1 ->
+			       let kn' = replace_mp_in_con mp1 mp kn in
+				 apply_opt_resolver resolve' kn')
+		    | Some t -> Some (subst_mps sub t)) res)
+      with
+	  BothSubstitutionsAreIdentitySubstitutions -> None
+	| ChangeDomain res ->
+	    let rec changeDom = function
+	      | [] -> []
+	      | (kn,topt)::r ->
+		  let key' =
+		    match key with
+			MSI msid -> MPself msid
+                      | MBI mbid -> MPbound mbid 
+		      | MPI mp1 -> mp1 in
+		  let kn' = replace_mp_in_con mp key' kn in
+		    if kn==kn' then
+		      (*the key does not appear in kn, we remove it
+			from the resolver that we are building*)
+		      changeDom r
+		    else
+		      (kn',topt)::(changeDom r)
+	    in
+	      Some (changeDom res)
+    in
+      mp',resolve'' in
   let subst = Umap.mapi (apply_subst subst2) subst1 in
-    Umap.fold Umap.add subst2 subst
- 
+    (Umap.fold Umap.add subst2 subst)
+      
+let subst_key subst1 subst2 =
+  let replace_in_key key (mp,resolve) sub=
+    let newkey = 
+      match key with
+	| MPI mp1 -> 
+	    begin
+	      match subst_mp0 subst1 mp1 with
+		| None -> None
+		| Some (mp2,_) -> Some (MPI mp2)
+	    end
+	| _ -> None
+    in
+      match newkey with
+	| None -> Umap.add key (mp,resolve) sub
+	| Some mpi -> Umap.add mpi (mp,resolve) sub
+  in
+    Umap.fold replace_in_key subst2 empty_subst
+
+let update_subst_alias subst1 subst2 =
+ let subst_inv key (mp,resolve) sub =
+    let newmp = 
+      match key with 
+	| MBI msid -> MPbound msid
+	| MSI msid -> MPself msid
+	| MPI mp -> mp
+    in
+   match mp with 
+     | MPbound mbid -> Umap.add (MBI mbid) (newmp,None) sub
+     | MPself msid -> Umap.add (MSI msid) (newmp,None) sub
+     | _ ->  Umap.add (MPI mp) (newmp,None) sub
+  in 
+  let subst_mbi = Umap.fold subst_inv subst2 empty_subst in
+  let alias_subst key (mp,resolve) sub=
+    let newkey = 
+      match key with
+	| MPI mp1 -> 
+	    begin
+	      match subst_mp0 subst_mbi mp1 with
+		| None -> None
+		| Some (mp2,_) -> Some (MPI mp2)
+	    end
+	| _ -> None
+    in
+      match newkey with
+	| None -> Umap.add key (mp,resolve) sub
+	| Some mpi -> Umap.add mpi (mp,resolve) sub
+  in
+    Umap.fold alias_subst subst1 empty_subst
+
+let update_subst subst1 subst2 =
+ let subst_inv key (mp,resolve) l =
+    let newmp = 
+      match key with 
+	| MBI msid -> MPbound msid
+	| MSI msid -> MPself msid
+	| MPI mp -> mp
+    in
+   match mp with 
+     | MPbound mbid ->  ((MBI mbid),newmp)::l
+     | MPself msid ->  ((MSI msid),newmp)::l
+     | _ ->   ((MPI mp),newmp)::l
+  in 
+  let subst_mbi = Umap.fold subst_inv subst2 [] in
+  let alias_subst key (mp,resolve) sub=
+    let newsetkey = 
+      match key with
+	| MPI mp1 -> 
+	    let compute_set_newkey l (k,mp') = 
+	      let mp_from_key = match k with
+		  	| MBI msid -> MPbound msid
+			| MSI msid -> MPself msid
+			| MPI mp -> mp
+	      in
+	      let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in
+		if new_mp1 == mp1 then l else (MPI new_mp1)::l
+	    in
+	    begin
+	      match List.fold_left compute_set_newkey [] subst_mbi with
+		| [] -> None
+		| l -> Some (l)
+	    end
+	| _ -> None
+    in
+      match newsetkey with
+	| None -> sub
+	| Some l -> 
+	    List.fold_left (fun s k -> Umap.add k (mp,resolve) s)
+	      sub l
+  in
+    Umap.fold alias_subst subst1 empty_subst
+
+let join_alias (subst1 : substitution) (subst2 : substitution) =
+  let apply_subst (sub : substitution) key (mp,resolve) =
+    let mp',resolve' =
+      match subst_mp0 sub mp with
+	  None -> mp, None
+	| Some (mp',resolve') -> mp',resolve' in
+    let resolve'' : resolver option =
+      try
+	let res =
+	  match resolve with
+              Some res -> res
+	    | None ->
+		match resolve' with
+		    None -> raise BothSubstitutionsAreIdentitySubstitutions
+		  | Some res -> raise (ChangeDomain res)
+	in
+	  Some
+	    (List.map
+               (fun (kn,topt) ->
+		  kn,
+		  match topt with
+		      None ->
+			(match key with
+			     MSI msid ->
+			       let kn' = replace_mp_in_con (MPself msid) mp kn in
+				 apply_opt_resolver resolve' kn'
+			   | MBI mbid ->
+			       let kn' = replace_mp_in_con (MPbound mbid) mp kn in
+				 apply_opt_resolver resolve' kn'
+			   | MPI mp1 ->
+			       let kn' = replace_mp_in_con mp1 mp kn in
+				 apply_opt_resolver resolve' kn')
+		    | Some t -> Some (subst_mps sub t)) res)
+      with
+	  BothSubstitutionsAreIdentitySubstitutions -> None
+	| ChangeDomain res ->
+	    let rec changeDom = function
+	      | [] -> []
+	      | (kn,topt)::r ->
+		  let key' =
+		    match key with
+			MSI msid -> MPself msid
+                      | MBI mbid -> MPbound mbid 
+		      | MPI mp1 -> mp1 in
+		  let kn' = replace_mp_in_con mp key' kn in
+		    if kn==kn' then
+		      (*the key does not appear in kn, we remove it
+			from the resolver that we are building*)
+		      changeDom r
+		    else
+		      (kn',topt)::(changeDom r)
+	    in
+	      Some (changeDom res)
+    in
+      mp',resolve'' in
+  Umap.mapi (apply_subst subst2) subst1 
+
+let remove_alias subst =
+  let rec remove key (mp,resolve) sub =
+    match key with
+	MPI _ -> sub
+      | _ -> Umap.add key (mp,resolve) sub
+  in
+    Umap.fold remove subst empty_subst
+      
 
 let rec occur_in_path uid path =
  match uid,path with
@@ -315,7 +492,8 @@ let force fsubst r =
 
 let subst_substituted s r =
   match !r with
-  | LSval a -> ref (LSlazy(s,a))
-  | LSlazy(s',a) ->
-      let s'' = join s' s in
-      ref (LSlazy(s'',a))
+    | LSval a -> ref (LSlazy(s,a))
+    | LSlazy(s',a) ->
+	let s'' = join s' s in
+	  ref (LSlazy(s'',a))
+	    
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index a7915a24..a2e45c52 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_subst.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id: mod_subst.mli 10849 2008-04-25 15:55:16Z soubiran $ i*)
 
 (*s [Mod_subst] *)
 
@@ -24,11 +24,15 @@ val add_msid :
   mod_self_id -> module_path -> substitution -> substitution
 val add_mbid : 
   mod_bound_id -> module_path -> resolver option -> substitution -> substitution
+val add_mp :
+  module_path -> module_path -> substitution -> substitution
 
 val map_msid :
   mod_self_id -> module_path -> substitution
 val map_mbid :
   mod_bound_id -> module_path -> resolver option -> substitution
+val map_mp :
+  module_path -> module_path -> substitution
 
 (* sequential composition: 
    [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
@@ -78,3 +82,13 @@ val subst_mps : substitution -> constr -> constr
 
 val occur_msid : mod_self_id -> substitution -> bool
 val occur_mbid : mod_bound_id -> substitution -> bool
+
+val update_subst_alias : substitution -> substitution -> substitution
+
+val update_subst : substitution -> substitution -> substitution
+
+val subst_key : substitution -> substitution -> substitution
+
+val join_alias : substitution -> substitution -> substitution
+
+val remove_alias : substitution -> substitution
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 70de3034..6840febd 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.ml 9980 2007-07-12 13:32:37Z soubiran $ i*)
+(*i $Id: mod_typing.ml 11170 2008-06-25 08:31:04Z soubiran $ i*)
 
 open Util
 open Names
@@ -22,14 +22,9 @@ open Mod_subst
 exception Not_path
 
 let path_of_mexpr = function
-  | MEident mb -> mb
+  | MSEident mp -> mp
   | _ -> raise Not_path
 
-let rec replace_first p k = function 
-  | [] -> [] 
-  | h::t when p h -> k::t
-  | h::t -> h::(replace_first p k t)
-
 let rec list_split_assoc k rev_before = function
   | [] -> raise Not_found
   | (k',b)::after when k=k' -> rev_before,b,after
@@ -42,28 +37,89 @@ let rec list_fold_map2 f e = function
        let e'',t1',t2' = list_fold_map2 f e' t in
 	 e'',h1'::t1',h2'::t2'
 
-let type_modpath env mp = 
-  strengthen env (lookup_module mp env).mod_type mp
+let rec check_with env mtb with_decl = 
+  match with_decl with
+    | With_Definition (id,_) -> 
+	let cb = check_with_aux_def env mtb with_decl in
+	  SEBwith(mtb,With_definition_body(id,cb)),empty_subst
+    | With_Module (id,mp) -> 
+	let cst,sub = check_with_aux_mod env mtb with_decl true in
+	  SEBwith(mtb,With_module_body(id,mp,cst)),sub
 
-let rec translate_modtype env mte =
-  match mte with
-    | MTEident ln -> MTBident ln
-    | MTEfunsig (arg_id,arg_e,body_e) -> 
-	let arg_b = translate_modtype env arg_e in
-	let env' = 
-	  add_module (MPbound arg_id) (module_body_of_type arg_b) env in
-	let body_b = translate_modtype env' body_e in
-	  MTBfunsig (arg_id,arg_b,body_b)
-    | MTEsig (msid,sig_e) ->
-	let str_b,sig_b = translate_entry_list env msid false sig_e in
-	  MTBsig (msid,sig_b)
-    | MTEwith (mte, with_decl) ->
-	let mtb = translate_modtype env mte in
-	  merge_with env mtb with_decl
+and check_with_aux_def env mtb with_decl = 
+  let msid,sig_b = match (eval_struct env mtb) with 
+    | SEBstruct(msid,sig_b) ->
+	msid,sig_b
+    | _ -> error_signature_expected mtb
+  in
+  let id,idl = match with_decl with 
+    | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
+    | With_Definition ([],_) | With_Module ([],_) -> assert false
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let env' = Modops.add_signature (MPself msid) before env in
+	match with_decl with
+          | With_Definition ([],_) -> assert false
+	  | With_Definition ([id],c) -> 
+	      let cb = match spec with
+		  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
+			  cb'
+		    | 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
+			  cb'
+	      end
+	  | With_Definition (_::_,_) ->
+	      let old = match spec with
+		  SFBmodule msb -> msb
+		| _ -> error_not_a_module (string_of_label l)
+	      in
+		begin
+		  match old.mod_expr with
+                    | None ->
+			let new_with_decl = match with_decl with
+			    With_Definition (_,c) -> With_Definition (idl,c)
+			  | With_Module (_,c) -> With_Module (idl,c) in 
+			  check_with_aux_def env' (type_of_mb env old) new_with_decl
+                    | Some msb ->
+			error_a_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
 
-and merge_with env mtb with_decl = 
-  let msid,sig_b = match (Modops.scrape_modtype env mtb) with 
-    | MTBsig(msid,sig_b) -> msid,sig_b 
+and check_with_aux_mod env mtb with_decl now = 
+  let initmsid,msid,sig_b = match (eval_struct env mtb) with 
+    | SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in
+	msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b)
     | _ -> error_signature_expected mtb
   in
   let id,idl = match with_decl with 
@@ -74,287 +130,251 @@ and merge_with env mtb with_decl =
     try
       let rev_before,spec,after = list_split_assoc l [] sig_b in
       let before = List.rev rev_before in
+      let rec mp_rec = function
+	| [] -> MPself initmsid
+	| i::r -> MPdot(mp_rec r,label_of_id i)
+      in 
       let env' = Modops.add_signature (MPself msid) before env in
-      let new_spec = match with_decl with
-        | With_Definition ([],_)
-        | With_Module ([],_) -> assert false
-	| With_Definition ([id],c) -> 
-	    let cb = match spec with
-		SPBconst cb -> cb
-	      | _ -> error_not_a_constant l
-	    in 
-	      begin
-		match cb.const_body with
-		  | None -> 
-		      let (j,cst1) = Typeops.infer env' c in
-		      let 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
-			SPBconst {cb with 
-				    const_body = body;
-			            const_body_code = Cemitcodes.from_val
-                        (compile_constant_body env' body false false);
-                                    const_constraints = 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
-			SPBconst {cb with 
-				    const_body = body;
-				    const_body_code = Cemitcodes.from_val
-                        (compile_constant_body env' body false false);
-                                    const_constraints = cst}
-	      end	
-(* and what about msid's ????? Don't they clash ? *)
-	| With_Module ([id], mp) ->
-	    let old = match spec with
-		SPBmodule msb -> msb
-	      | _ -> error_not_a_module (string_of_label l)
-	    in
-	    let mtb = type_modpath env' mp in
-	 (* here, using assertions in substitutions, 
-	    we check that there is no msid bound in mtb *)
-	    begin
-	      try 
-		let _ = subst_modtype (map_msid msid (MPself msid)) mtb in
-		  ()
-	      with
-		  Circularity _ -> error_circular_with_module id
-	    end;
-	    let cst =
-              try check_subtypes env' mtb old.msb_modtype
-              with Failure _ -> error_with_incorrect (label_of_id id) in
-	    let equiv = 
- 	      match old.msb_equiv with
-		| None -> Some mp
-		| Some mp' ->
-		    begin
-		      try 
-			check_modpath_equiv env' mp mp'
-		      with Not_equiv_path -> error_not_equal mp mp
-		    end;
-		    Some mp
-	    in
-	    let msb =
-	      {msb_modtype = mtb; 
-	       msb_equiv = equiv; 
-	       msb_constraints = Constraint.union old.msb_constraints cst }
-	    in
-	      SPBmodule msb
-	| With_Definition (_::_,_)
-        | With_Module (_::_,_) -> 
+	match with_decl with
+          | With_Module ([],_) -> assert false
+	  | With_Module ([id], mp) ->
+	      let old,alias = match spec with
+		  SFBmodule msb -> Some msb,None
+		| SFBalias (mp',cst) -> None,Some (mp',cst)
+		| _ -> error_not_a_module (string_of_label l)
+	      in
+	      let mtb' = lookup_modtype mp env' in
+	      let cst =
+		match old,alias with
+		    Some msb,None ->
+		      begin
+			try Constraint.union 
+			  (check_subtypes env' mtb' (module_type_of_module None msb))
+			  msb.mod_constraints
+			with Failure _ -> error_with_incorrect (label_of_id id)
+		      end
+		  | None,Some (mp',None) ->
+		      check_modpath_equiv env' mp mp';
+		      Constraint.empty
+		  | None,Some (mp',Some cst) ->
+		      check_modpath_equiv env' mp mp';
+		      cst
+		  | _,_ ->
+		      anomaly "Mod_typing:no implementation and no alias"
+	      in
+		if now then 
+		  let mp' = scrape_alias mp env' in
+		  let up_subst = update_subst mtb'.typ_alias (map_mp (mp_rec [id]) mp') in
+		    cst, (join (map_mp (mp_rec [id]) mp') up_subst)
+		else
+		cst,empty_subst
+        | With_Module (_::_,mp) -> 
 	    let old = match spec with
-		SPBmodule msb -> msb
+		SFBmodule msb -> msb
 	      | _ -> error_not_a_module (string_of_label l)
 	    in
 	      begin
-		match old.msb_equiv with
-                   None ->
-                    let new_with_decl = match with_decl with
-                       With_Definition (_,c) -> With_Definition (idl,c)
-                     | With_Module (_,c) -> With_Module (idl,c) in
-                    let modtype = 
-                     merge_with env' old.msb_modtype new_with_decl in
-                    let msb =
-	              {msb_modtype = modtype; 
-	               msb_equiv = None; 
-	               msb_constraints = old.msb_constraints }
-	            in
-	             SPBmodule msb
-                 | Some mp ->
-                    error_a_generative_module_expected l
+		match old.mod_expr with
+                    None ->
+                      let new_with_decl = match with_decl with
+			  With_Definition (_,c) -> 
+			    With_Definition (idl,c)
+			| With_Module (_,c) -> With_Module (idl,c) in
+		      let cst,_ =
+			check_with_aux_mod env' 
+			  (type_of_mb env old) new_with_decl false in
+			if now then 
+			  let mtb' = lookup_modtype mp env' in
+			  let mp' = scrape_alias mp env' in
+			  let up_subst = update_subst 
+			    mtb'.typ_alias (map_mp (mp_rec (List.rev (id::idl))) mp') in
+			    cst, (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst)
+		else
+		cst,empty_subst
+		  | Some msb ->
+                      error_a_generative_module_expected l
               end
-      in
-	MTBsig(msid,  before@(l,new_spec)::after)
+	| _ -> anomaly "Modtyping:incorrect use of with"
     with
 	Not_found -> error_no_such_label l
       | Reduction.NotConvertible -> error_with_incorrect l
-
-and translate_entry_list env msid is_definition sig_e = 
-  let mp = MPself msid in
-  let do_entry env (l,e) = 
-    let kn = make_kn mp empty_dirpath l in
-    let con = make_con mp empty_dirpath l in
-    match e with
-      | SPEconst ce ->
-	  let cb = translate_constant env con ce in
-	    begin match cb.const_hyps with
-	      |	(_::_) -> error_local_context (Some l)
-	      | [] ->
-		  add_constant con cb env, (l, SEBconst cb), (l, SPBconst cb)
-	    end
-      | SPEmind mie -> 
-	  let mib = translate_mind env mie in
-	    begin match mib.mind_hyps with
-	      |	(_::_) -> error_local_context (Some l)
-	      | [] ->
-		  add_mind kn mib env, (l, SEBmind mib), (l, SPBmind mib)
-	    end
-      | SPEmodule me ->
-	  let mb = translate_module env is_definition me in
-	  let mspec = 
-	    { msb_modtype = mb.mod_type;
-	      msb_equiv = mb.mod_equiv;
-	      msb_constraints = mb.mod_constraints }
-	  in
-	  let mp' = MPdot (mp,l) in
-	    add_module mp' mb env, (l, SEBmodule mb), (l, SPBmodule mspec)
-      | SPEmodtype mte ->
-	  let mtb = translate_modtype env mte in
-	    add_modtype kn mtb env, (l, SEBmodtype mtb), (l, SPBmodtype mtb)
-  in
-  let _,str_b,sig_b = list_fold_map2 do_entry env sig_e
-  in
-    str_b,sig_b
-
-(* if [is_definition=true], [mod_entry_expr] may be any expression.
-   Otherwise it must be a path *)
-
-and translate_module env is_definition me =
+	  
+and translate_module env me =
   match me.mod_entry_expr, me.mod_entry_type with
     | None, None -> 
 	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
     | None, Some mte -> 
-	let mtb = translate_modtype env mte in
+	let mtb,sub = translate_struct_entry env mte in
 	{ mod_expr = None;
-	  mod_user_type = Some mtb;
-	  mod_type = mtb;
-	  mod_equiv = None;
-	  mod_constraints = Constraint.empty }
+	  mod_type = Some mtb;
+	  mod_alias = sub;
+	  mod_constraints = Constraint.empty; 
+	  mod_retroknowledge = []}
     | Some mexpr, _ -> 
-	let meq_o = (* do we have a transparent module ? *)
-	  try       (* TODO: transparent field in module_entry *)
-	    match me.mod_entry_type with
-	      | None -> Some (path_of_mexpr mexpr)
-	      | Some _ -> None
-	  with 
-	    | Not_path -> None
-	in
-	let meb,mtb1 = 
-	  if is_definition then
-	    translate_mexpr env mexpr
-	  else 
-	    let mp = 
-	      try 
-		path_of_mexpr mexpr 
-	      with 
-		| Not_path -> error_declaration_not_path mexpr
-	    in
-	      MEBident mp, type_modpath env mp
-	in
-	let mtb, mod_user_type, cst =
+	let meb,sub1 = translate_struct_entry env mexpr in
+	let mod_typ,sub,cst =
 	  match me.mod_entry_type with
-	    | None -> mtb1, None, Constraint.empty
+	    | None ->  None,sub1,Constraint.empty
 	    | Some mte -> 
-		let mtb2 = translate_modtype env mte in
-                let cst = check_subtypes env mtb1 mtb2 in
-		    mtb2, Some mtb2, cst
+		let mtb2,sub2 = translate_struct_entry env mte in
+                let cst = check_subtypes env
+		  {typ_expr = meb;
+		   typ_strength = None;
+		   typ_alias = sub1;}
+		  {typ_expr = mtb2;
+		   typ_strength = None;
+		   typ_alias = sub2;}
+		in
+		  Some mtb2,sub2,cst
 	in
-	  { mod_type = mtb;
-	    mod_user_type = mod_user_type;
+	  { mod_type = mod_typ;
 	    mod_expr = Some meb;
-	    mod_equiv = meq_o;
-	    mod_constraints = cst }
+	    mod_constraints = cst;
+	    mod_alias = sub;
+	    mod_retroknowledge = []} (* spiwack: not so sure about that. It may
+					cause a bug when closing nested modules.
+					If it does, I don't really know how to
+					fix the bug.*)
 
-(* translate_mexpr : env -> module_expr -> module_expr_body * module_type_body *)
-and translate_mexpr env mexpr = match mexpr with
-  | MEident mp -> 
-      MEBident mp,
-      type_modpath env mp
-  | MEfunctor (arg_id, arg_e, body_expr) ->
-      let arg_b = translate_modtype env arg_e in
-      let env' = add_module (MPbound arg_id) (module_body_of_type arg_b) env in
-      let (body_b,body_tb) = translate_mexpr env' body_expr in
-	MEBfunctor (arg_id, arg_b, body_b), 
-	MTBfunsig (arg_id, arg_b, body_tb)
-  | MEapply (fexpr,mexpr) ->
-      let feb,ftb = translate_mexpr env fexpr in
-      let ftb = scrape_modtype env ftb in
-      let farg_id, farg_b, fbody_b = destr_functor ftb in
-      let meb,mtb = translate_mexpr env mexpr in
-      let cst = check_subtypes env mtb farg_b in
-      let mp = 
+
+and translate_struct_entry env mse = match mse with
+  | MSEident mp ->
+      let mtb = lookup_modtype mp env in 
+      SEBident mp,mtb.typ_alias
+  | MSEfunctor (arg_id, arg_e, body_expr) ->
+      let arg_b,sub = translate_struct_entry env arg_e in
+      let mtb =
+	{typ_expr = arg_b;
+	 typ_strength = None;
+	 typ_alias = sub} in
+      let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in
+      let body_b,sub = translate_struct_entry env' body_expr in
+	SEBfunctor (arg_id, mtb, body_b),sub
+  | MSEapply (fexpr,mexpr) ->
+      let feb,sub1 = translate_struct_entry env fexpr in
+      let feb'= eval_struct env feb
+      in
+      let farg_id, farg_b, fbody_b = destr_functor env feb' in
+      let mtb,mp = 
 	try
-	  path_of_mexpr mexpr 
+	  let mp = scrape_alias (path_of_mexpr mexpr) env in
+	  lookup_modtype mp env,mp
 	with
 	  | Not_path -> error_application_to_not_path mexpr
-	      (* place for nondep_supertype *)
-      in
-       let resolve = Modops.resolver_of_environment farg_id farg_b mp env in
-	MEBapply(feb,meb,cst),
-        (* This is the place where the functor formal parameter is
-           substituted by the given argument to compute the type of the
-           functor application. *)
-	subst_modtype
-         (map_mbid farg_id mp (Some resolve)) fbody_b
-  | MEstruct (msid,structure) ->
-      let structure,signature = translate_entry_list env msid true structure in
-	MEBstruct (msid,structure),
-	MTBsig (msid,signature)
-
-
-(* is_definition is true - me.mod_entry_expr may be any expression *)
-let translate_module env me = translate_module env true me
+	      (* place for nondep_supertype *) in
+      let meb,sub2= translate_struct_entry env (MSEident mp) in
+	if sub1 = empty_subst then 
+	  let cst = check_subtypes env mtb farg_b in
+	    SEBapply(feb,meb,cst),sub1
+	else
+	  let sub2 = match eval_struct env (SEBident mp) with
+	    | SEBstruct (msid,sign) -> 
+		join_alias 
+		  (subst_key (map_msid msid mp) sub2)
+		  (map_msid msid mp)
+	    | _ -> sub2 in
+	  let sub3 = join_alias sub1 (map_mbid farg_id mp None) in
+	  let sub4 = update_subst sub2 sub3 in
+	  let cst = check_subtypes env mtb farg_b in
+	    SEBapply(feb,meb,cst),(join sub3 sub4)
+  | MSEwith(mte, with_decl) ->
+	let mtb,sub1 = translate_struct_entry env mte in
+	let mtb',sub2 = check_with env mtb with_decl in
+	  mtb',join sub1 sub2
+	    
 
-let rec add_module_expr_constraints env = function
-  | MEBident _ -> env
+let rec add_struct_expr_constraints env = function
+  | SEBident _ -> env
 
-  | MEBfunctor (_,mtb,meb) -> 
-      add_module_expr_constraints (add_modtype_constraints env mtb) meb
+  | SEBfunctor (_,mtb,meb) -> 
+      add_struct_expr_constraints 
+	(add_modtype_constraints env mtb) meb
 
-  | MEBstruct (_,mod_struct_body) ->
+  | SEBstruct (_,structure_body) ->
       List.fold_left 
         (fun env (l,item) -> add_struct_elem_constraints env item)
         env
-        mod_struct_body
+        structure_body
 
-  | MEBapply (meb1,meb2,cst) ->
+  | SEBapply (meb1,meb2,cst) ->
       Environ.add_constraints cst 
-        (add_module_expr_constraints 
-	  (add_module_expr_constraints env meb1) 
+        (add_struct_expr_constraints 
+	  (add_struct_expr_constraints env meb1) 
 	  meb2)
-
+  | SEBwith(meb,With_definition_body(_,cb))->
+      Environ.add_constraints cb.const_constraints
+	(add_struct_expr_constraints env meb)
+  | SEBwith(meb,With_module_body(_,_,cst))->
+      Environ.add_constraints cst
+	(add_struct_expr_constraints env meb)	
+		
 and add_struct_elem_constraints env = function 
-  | SEBconst cb -> Environ.add_constraints cb.const_constraints env
-  | SEBmind mib -> Environ.add_constraints mib.mind_constraints env
-  | SEBmodule mb -> add_module_constraints env mb
-  | SEBmodtype mtb -> add_modtype_constraints env mtb
+  | SFBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SFBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SFBmodule mb -> add_module_constraints env mb
+  | SFBalias (mp,Some cst) -> Environ.add_constraints cst env
+  | SFBalias (mp,None) -> env
+  | SFBmodtype mtb -> add_modtype_constraints env mtb
 
 and add_module_constraints env mb = 
-  (* if there is a body, the mb.mod_type is either inferred from the
-     body and hence uninteresting or equal to the non-empty
-     user_mod_type *)
   let env = match mb.mod_expr with
-    | None -> add_modtype_constraints env mb.mod_type
-    | Some meb -> add_module_expr_constraints env meb
+    | None -> env
+    | Some meb -> add_struct_expr_constraints env meb
   in
-  let env = match mb.mod_user_type with
+  let env = match mb.mod_type with
     | None -> env
-    | Some mtb -> add_modtype_constraints env mtb
+    | Some mtb -> 
+	add_struct_expr_constraints env mtb
   in
     Environ.add_constraints mb.mod_constraints env
 
-and add_modtype_constraints env = function
-  | MTBident _ -> env
-  | MTBfunsig (_,mtb1,mtb2) ->
-      add_modtype_constraints
-        (add_modtype_constraints env mtb1)
-        mtb2
-  | MTBsig (_,mod_sig_body) ->
+and add_modtype_constraints env mtb = 
+  add_struct_expr_constraints env mtb.typ_expr
+      
+
+let rec struct_expr_constraints cst = function
+  | SEBident _ -> cst
+
+  | SEBfunctor (_,mtb,meb) -> 
+      struct_expr_constraints 
+	(modtype_constraints cst mtb) meb
+
+  | SEBstruct (_,structure_body) ->
       List.fold_left 
-        (fun env (l,item) -> add_sig_elem_constraints env item)
-        env
-        mod_sig_body
+        (fun cst (l,item) -> struct_elem_constraints cst item)
+        cst
+        structure_body
+
+  | SEBapply (meb1,meb2,cst1) ->
+      struct_expr_constraints 
+	(struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
+	meb2
+  | SEBwith(meb,With_definition_body(_,cb))->
+      struct_expr_constraints
+        (Univ.Constraint.union cb.const_constraints cst) meb
+  | SEBwith(meb,With_module_body(_,_,cst1))->
+      struct_expr_constraints (Univ.Constraint.union cst1 cst) meb	
+		
+and struct_elem_constraints cst = function 
+  | SFBconst cb -> cst
+  | SFBmind mib -> cst
+  | SFBmodule mb -> module_constraints cst mb
+  | SFBalias (mp,Some cst1) -> Univ.Constraint.union cst1 cst
+  | SFBalias (mp,None) -> cst
+  | SFBmodtype mtb -> modtype_constraints cst mtb
 
-and add_sig_elem_constraints env = function 
-  | SPBconst cb -> Environ.add_constraints cb.const_constraints env
-  | SPBmind mib -> Environ.add_constraints mib.mind_constraints env
-  | SPBmodule {msb_modtype=mtb; msb_constraints=cst} -> 
-      add_modtype_constraints (Environ.add_constraints cst env) mtb
-  | SPBmodtype mtb -> add_modtype_constraints env mtb
+and module_constraints cst mb = 
+  let cst = match mb.mod_expr with
+    | None -> cst
+    | Some meb -> struct_expr_constraints cst meb in
+  let cst = match mb.mod_type with
+    | None -> cst
+    | Some mtb -> struct_expr_constraints cst mtb in
+  Univ.Constraint.union mb.mod_constraints cst
 
+and modtype_constraints cst mtb = 
+  struct_expr_constraints cst mtb.typ_expr
+      
 
+let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty
+let module_constraints = module_constraints Univ.Constraint.empty
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index 706c617c..b9c68a23 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -6,22 +6,27 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id: mod_typing.mli 11170 2008-06-25 08:31:04Z soubiran $ i*)
 
 (*i*)
 open Declarations
 open Environ
 open Entries
+open Mod_subst
 (*i*)
 
 
-val translate_modtype : env -> module_type_entry -> module_type_body
-
 val translate_module : env -> module_entry -> module_body
 
-val translate_mexpr : env -> module_expr -> module_expr_body * module_type_body
+val translate_struct_entry : env -> module_struct_entry -> 
+  struct_expr_body * substitution
 
 val add_modtype_constraints : env -> module_type_body -> env
 
 val add_module_constraints : env -> module_body -> env
 
+val add_struct_expr_constraints : env -> struct_expr_body -> env
+
+val struct_expr_constraints : struct_expr_body -> Univ.constraints
+
+val module_constraints : module_body -> Univ.constraints
diff --git a/kernel/modops.ml b/kernel/modops.ml
index fb00cfcd..9242a757 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml 9980 2007-07-12 13:32:37Z soubiran $ i*)
+(*i $Id: modops.ml 11142 2008-06-18 15:37:31Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -20,7 +20,6 @@ open Entries
 open Mod_subst
 (*i*)
 
-exception Circularity of string
 
 let error_existing_label l = 
   error ("The label "^string_of_label l^" is already declared")
@@ -33,11 +32,10 @@ let error_not_a_functor _ = error "Application of not a functor"
 
 let error_incompatible_modtypes _ _ = error "Incompatible module types"
 
-let error_not_equal p1 p2 = error ((string_of_mp p1)^" and "^(string_of_mp p2)^" are not equal modules")
+let error_not_equal _ _ = error "Not equal modules"
+
+let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match")
 
-let error_not_match l l1 l2 = error (l1^" is not a subtype of "^l2^": "^
-				       "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' = 
@@ -83,140 +81,332 @@ let error_local_context lo =
 	error ("The local context of the component "^
 	       (string_of_label l)^" is not empty")
 
-let error_circular_with_module l =
-  error ("The construction \"with Module "^(string_of_id l)^":=...\" is about to create\na circular module type. Their resolution is not implemented yet.\nIf you really need that feature, please report.")
-
-let error_circularity_in_subtyping l l1 l2 =
-  error ("An occurrence of "^l^" creates a circularity\n during the subtyping verification between "^l1^" and "^l2^".")
 
 let error_no_such_label_sub l l1 l2 =
-  error (l1^" is not a subtype of "^l2^":"^"The field "^(string_of_label l)^" is missing in "^l1^".")
+  error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing in "^l1^".")
 
 
-let rec scrape_modtype env = function
-  | MTBident kn -> scrape_modtype env (lookup_modtype kn env)
-  | mtb -> mtb
 
-(* the constraints are not important here *)
-let module_body_of_spec msb = 
-    { mod_type = msb.msb_modtype;
-      mod_equiv = msb.msb_equiv;
-      mod_expr = None;
-      mod_user_type = None;
-      mod_constraints = Constraint.empty}
-
-let module_body_of_type mtb = 
-  { mod_type = mtb;
-    mod_equiv = None;
-    mod_expr = None;
-    mod_user_type = None;
-    mod_constraints = Constraint.empty}
+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 path_of_seb = function
+  | SEBident mp -> mp
+  | _ -> anomaly "Modops: evaluation failed."
 
-(* the constraints are not important here *)
-let module_spec_of_body mb = 
-  { msb_modtype = mb.mod_type; 
-    msb_equiv = mb.mod_equiv; 
-    msb_constraints = Constraint.empty}
 
+let destr_functor env mtb =
+  match mtb with
+  | SEBfunctor (arg_id,arg_t,body_t) ->
+      	    (arg_id,arg_t,body_t)
+  | _ -> error_not_a_functor mtb
 
+(* the constraints are not important here *)
 
-let destr_functor = function
-  | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
-  | mtb -> error_not_a_functor mtb
- 
-exception Not_equiv_path 
+let module_body_of_type mtb = 
+  { mod_type = Some mtb.typ_expr;
+    mod_expr = None;
+    mod_constraints = Constraint.empty;
+    mod_alias = mtb.typ_alias;
+    mod_retroknowledge = []}
+
+let module_type_of_module mp mb =
+  {typ_expr = 
+      (match mb.mod_type with
+	| Some expr -> expr
+	| None -> (match mb.mod_expr with
+		     | Some expr -> expr
+		     | None -> 
+			 anomaly "Modops: empty expr and type"));
+   typ_alias = mb.mod_alias;
+   typ_strength = mp
+  }
 
 let rec check_modpath_equiv env mp1 mp2 = 
   if mp1=mp2 then () else
-  let mb1 = lookup_module mp1 env in
-    match mb1.mod_equiv with
-      | None ->
-	  let mb2 = lookup_module mp2 env in
-	    (match mb2.mod_equiv with
-	      | None -> raise Not_equiv_path
-	      | Some mp2' -> check_modpath_equiv env mp2' mp1)
-      | Some mp1' -> check_modpath_equiv env mp2 mp1'
-
-
-let rec subst_modtype sub = function
-    (* This is the case in which I am substituting a whole module.
-       For instance "Module M(X). Module N := X. End M". When I apply
-       M to M' I must substitute M' for X in "Module N := X". *)
-  | MTBident ln -> MTBident (subst_kn sub ln)
-  | MTBfunsig (arg_id, arg_b, body_b) ->
-      if occur_mbid arg_id sub then raise (Circularity (string_of_mbid arg_id));
-      MTBfunsig (arg_id, 
-		 subst_modtype sub arg_b, 
-		 subst_modtype sub body_b)
-  | MTBsig (sid1, msb) -> 
-      if occur_msid sid1 sub then raise (Circularity (string_of_msid sid1));
-      MTBsig (sid1, subst_signature sub msb)
-
-and subst_signature sub sign = 
-  let subst_body = function
-      SPBconst cb -> 
-	SPBconst (subst_const_body sub cb)
-    | SPBmind mib -> 
-	SPBmind (subst_mind sub mib)
-    | SPBmodule mb -> 
-	SPBmodule (subst_module sub mb)
-    | SPBmodtype mtb -> 
-	SPBmodtype (subst_modtype sub mtb)
+  let mp1 = scrape_alias mp1 env in
+  let mp2 = scrape_alias mp2 env in
+    if mp1=mp2 then ()
+    else 
+      error_not_equal mp1 mp2
+	
+let subst_with_body sub = function
+  | With_module_body(id,mp,cst) ->
+      With_module_body(id,subst_mp sub mp,cst)
+  | With_definition_body(id,cb) ->
+      With_definition_body( id,subst_const_body sub cb)
+
+let rec subst_modtype sub mtb =
+  let typ_expr' = subst_struct_expr sub mtb.typ_expr in
+    if typ_expr'==mtb.typ_expr then
+      mtb
+    else
+      { mtb with 
+	  typ_expr = typ_expr'}
+	
+and subst_structure sub sign = 
+  let subst_body  = function
+      SFBconst cb -> 
+	SFBconst (subst_const_body sub cb)
+    | SFBmind mib -> 
+	SFBmind (subst_mind sub mib)
+    | SFBmodule mb -> 
+	SFBmodule (subst_module sub mb)
+    | SFBmodtype mtb -> 
+	SFBmodtype (subst_modtype sub mtb)
+    | SFBalias (mp,cst) ->
+	SFBalias (subst_mp sub mp,cst)
   in
     List.map (fun (l,b) -> (l,subst_body b)) sign
 
-and subst_module sub mb =
-  let mtb' = subst_modtype sub mb.msb_modtype in
+and subst_module  sub mb =
+  let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in
   (* This is similar to the previous case. In this case we have
      a module M in a signature that is knows to be equivalent to a module M'
      (because the signature is "K with Module M := M'") and we are substituting
      M' with some M''. *)
-  let mpo' = option_smartmap (subst_mp sub) mb.msb_equiv in
-    if mtb'==mb.msb_modtype && mpo'==mb.msb_equiv then mb else
-      { msb_modtype=mtb'; 
-	msb_equiv=mpo'; 
-	msb_constraints=mb.msb_constraints}
+  let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in
+  let mb_alias = update_subst sub mb.mod_alias in
+   let mb_alias =  if mb_alias = empty_subst then
+     join_alias mb.mod_alias sub 
+   else 
+     join mb_alias (join_alias mb.mod_alias sub)
+   in
+     if mtb'==mb.mod_type && mb.mod_expr == me' 
+      && mb_alias == mb.mod_alias
+    then mb else
+      { mod_expr = me';
+	mod_type=mtb'; 
+	mod_constraints=mb.mod_constraints;
+	mod_alias = mb_alias;
+	mod_retroknowledge=mb.mod_retroknowledge}
+
+
+and subst_struct_expr sub = function
+    | SEBident mp -> SEBident (subst_mp sub  mp)
+    | SEBfunctor (msid, mtb, meb') -> 
+	SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb')
+    | SEBstruct (msid,str)->
+	SEBstruct(msid, subst_structure sub str)
+    | SEBapply (meb1,meb2,cst)->
+	SEBapply(subst_struct_expr sub meb1,
+		 subst_struct_expr sub meb2,
+		 cst)
+    | SEBwith (meb,wdb)-> 
+	SEBwith(subst_struct_expr sub meb,
+		subst_with_body sub wdb)
+ 
 
 let subst_signature_msid msid mp = 
-  subst_signature (map_msid msid mp)
+  subst_structure (map_msid msid mp)
+
+(* spiwack: here comes the function which takes care of importing 
+   the retroknowledge declared in the library *)
+(* lclrk : retroknowledge_action list, rkaction : retroknowledge action *)
+let add_retroknowledge msid mp =
+  let subst = add_msid msid mp empty_subst in
+  let subst_and_perform rkaction env =
+    match rkaction with
+      | Retroknowledge.RKRegister (f, e) ->
+	  Environ.register env f 
+	  (match e with 
+	    | Const kn -> kind_of_term (subst_mps subst (mkConst kn))
+	    | Ind ind -> kind_of_term (subst_mps subst (mkInd ind))
+	    | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term")
+  in
+  fun lclrk env ->
+  (* The order of the declaration matters, for instance (and it's at the
+     time this comment is being written, the only relevent instance) the
+     int31 type registration absolutely needs int31 bits to be registered.
+     Since the local_retroknowledge is stored in reverse order (each new
+     registration is added at the top of the list) we need a fold_right
+     for things to go right (the pun is not intented). So we lose 
+     tail recursivity, but the world will have exploded before any module
+     imports 10 000 retroknowledge registration.*)
+  List.fold_right subst_and_perform lclrk env
+
+
+
+let strengthen_const env mp l cb = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None -> 
+      let const = mkConst (make_con mp empty_dirpath l) 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 strengthen_mind env mp l mib = match mib.mind_equiv with
+  | Some _ -> mib
+  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
 
-(* we assume that the substitution of "mp" into "msid" is already done
-(or unnecessary) *)
-let rec add_signature mp sign env = 
+
+let rec eval_struct env = function 
+  | SEBident mp -> 
+      begin
+	let mtb =lookup_modtype mp env in
+	match mtb.typ_expr,mtb.typ_strength with
+	    mtb,None -> eval_struct env mtb
+	  | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb)
+      end
+  | SEBapply (seb1,seb2,_) -> 
+      let svb1 = eval_struct env seb1 in
+      let farg_id, farg_b, fbody_b = destr_functor env svb1 in
+      let mp = path_of_seb seb2 in
+      let mp = scrape_alias mp env in
+      let sub_alias = (lookup_modtype mp env).typ_alias in
+      let sub_alias = match eval_struct env (SEBident mp) with
+	| SEBstruct (msid,sign) ->
+	    join_alias 
+	      (subst_key (map_msid msid mp) sub_alias)
+	      (map_msid msid mp)
+	| _ -> sub_alias in
+      let sub_alias1 = update_subst sub_alias 
+	(map_mbid farg_id mp (None)) in
+      let resolve = resolver_of_environment farg_id farg_b mp sub_alias env in
+	eval_struct env (subst_struct_expr 
+			   (join sub_alias1 
+			      (map_mbid farg_id mp (Some resolve))) fbody_b)
+  | SEBwith (mtb,(With_definition_body _ as wdb)) ->
+      let mtb',_ = merge_with env mtb wdb empty_subst in
+	mtb'
+  | SEBwith (mtb, (With_module_body (_,mp,_) as wdb)) ->
+      let alias_in_mp =
+	(lookup_modtype mp env).typ_alias in
+      let alias_in_mp = match eval_struct env (SEBident mp) with
+	| SEBstruct (msid,sign) -> subst_key (map_msid msid mp) alias_in_mp
+	| _ -> alias_in_mp in
+      let mtb',_ = merge_with env mtb wdb alias_in_mp in
+	mtb'
+(*  | SEBfunctor(mbid,mtb,body) -> 
+    let env = add_module (MPbound mbid) (module_body_of_type mtb) env in
+    SEBfunctor(mbid,mtb,eval_struct env body) *)
+  | mtb -> mtb
+      
+and type_of_mb env mb =
+  match mb.mod_type,mb.mod_expr with
+      None,Some b -> eval_struct env b
+    | Some t, _ -> eval_struct env t
+    | _,_ -> anomaly 
+	"Modops:  empty type and empty expr" 
+	  
+and merge_with env mtb with_decl alias= 
+  let msid,sig_b = match (eval_struct env mtb) with 
+    | SEBstruct(msid,sig_b) -> msid,sig_b
+    | _ -> error_signature_expected mtb
+  in
+  let id,idl = match with_decl with 
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) -> id,idl
+    | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let rec mp_rec = function
+	| [] -> MPself msid
+	| i::r -> MPdot(mp_rec r,label_of_id i)
+      in 
+      let new_spec,subst = match with_decl with
+        | With_definition_body ([],_)
+        | With_module_body ([],_,_) -> assert false
+	| With_definition_body ([id],c) -> 
+	    SFBconst c,None
+	| With_module_body ([id], mp,cst) ->
+	    let mp' = scrape_alias mp env in
+	    let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in
+	      SFBalias (mp,Some cst),
+	    Some(join (map_mp (mp_rec [id]) mp') new_alias)
+	| With_definition_body (_::_,_) 
+        | With_module_body (_::_,_,_) -> 
+	    let old = match spec with
+		SFBmodule msb -> msb
+	      | _ -> error_not_a_module (string_of_label l)
+	    in
+            let new_with_decl,subst1 = 
+	      match with_decl with
+                  With_definition_body (_,c) -> With_definition_body (idl,c),None
+		| With_module_body (idc,mp,cst) -> 
+		    let mp' = scrape_alias mp env in
+		    With_module_body (idl,mp,cst),
+		      Some(map_mp (mp_rec (List.rev idc)) mp') 
+	    in
+	    let subst = match subst1 with
+	      | None -> None
+	      | Some s -> Some (join s (update_subst alias s)) in
+            let modtype,subst_msb = 
+              merge_with env (type_of_mb env old) new_with_decl alias in
+            let msb =
+	      { mod_expr = None;
+		mod_type = Some modtype; 
+		mod_constraints = old.mod_constraints;
+		mod_alias = begin 
+		  match subst_msb with
+		    |None -> empty_subst
+		    |Some s -> s
+		end;
+		mod_retroknowledge = old.mod_retroknowledge}
+	    in
+	      (SFBmodule msb),subst
+      in
+	SEBstruct(msid,  before@(l,new_spec)::
+		    (Option.fold_right subst_structure subst after)),subst
+    with
+	Not_found -> error_no_such_label l
+
+and add_signature mp sign env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
     let con = make_con mp empty_dirpath l in
       match elem with
-	| SPBconst cb -> Environ.add_constant con cb env
-	| SPBmind mib -> Environ.add_mind kn mib env
-	| SPBmodule mb -> 
-	    add_module (MPdot (mp,l)) (module_body_of_spec mb) env 
-	    (* adds components as well *)
-	| SPBmodtype mtb -> Environ.add_modtype kn mtb env
+	| SFBconst cb -> Environ.add_constant con cb env
+	| SFBmind mib -> Environ.add_mind kn mib env
+	| SFBmodule mb -> 
+	    add_module (MPdot (mp,l)) mb env 
+	      (* adds components as well *)
+	| SFBalias (mp1,cst) -> 
+	    Environ.register_alias (MPdot(mp,l)) mp1 env
+	| SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) 
+	    mtb env
   in
     List.fold_left add_one env sign
 
-
 and add_module mp mb env = 
   let env = Environ.shallow_add_module mp mb env in
-    match scrape_modtype env mb.mod_type with
-      | MTBident _ -> anomaly "scrape_modtype does not work!"
-      | MTBsig (msid,sign) -> 
-	  add_signature mp (subst_signature_msid msid mp sign) env
-      | MTBfunsig _ -> env
+  let env =
+    Environ.add_modtype mp (module_type_of_module (Some mp) mb) env
+  in
+  let mod_typ = type_of_mb env mb in
+    match mod_typ with
+      | SEBstruct (msid,sign) -> 
+	  add_retroknowledge msid mp (mb.mod_retroknowledge)
+	    (add_signature mp (subst_signature_msid msid mp sign) env)
+      | SEBfunctor _ -> env
+      | _ -> anomaly "Modops:the evaluation of the structure failed "
+	  
 
 
-let rec constants_of_specification env mp sign =
+and  constants_of_specification env mp sign =
  let aux (env,res) (l,elem) =
   match elem with
-   | SPBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
-   | SPBmind _ -> env,res
-   | SPBmodule mb ->
-       let new_env =  add_module (MPdot (mp,l)) (module_body_of_spec mb) env in 
+   | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
+   | SFBmind _ -> env,res
+   | SFBmodule mb ->
+       let new_env =  add_module (MPdot (mp,l)) mb env in 
+       new_env,(constants_of_modtype env (MPdot (mp,l))
+		   (type_of_mb env mb)) @ res
+   | SFBalias (mp1,cst) ->
+       let new_env =  register_alias (MPdot (mp,l)) mp1 env in 
        new_env,(constants_of_modtype env (MPdot (mp,l))
-		  (module_body_of_spec mb).mod_type) @ res
-   | SPBmodtype mtb -> 
+		   (eval_struct env (SEBident mp1))) @ res
+   | SFBmodtype mtb -> 
        (* module type dans un module type. 
 	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
 	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
@@ -232,87 +422,98 @@ let rec constants_of_specification env mp sign =
 	  si on ne rajoute pas T2 dans l'environement de typage 
 	  on va exploser au moment du Declare Module
        *)
-       let new_env = Environ.add_modtype (make_kn mp empty_dirpath l) mtb env in 
-       new_env, constants_of_modtype env (MPdot(mp,l)) mtb @ res
+       let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in 
+       new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res
  in
  snd (List.fold_left aux (env,[]) sign)
 
 and constants_of_modtype env mp modtype =
- match scrape_modtype env modtype with
-    MTBident _ -> anomaly "scrape_modtype does not work!"
-  | MTBsig (msid,sign) ->
-     constants_of_specification env mp
-      (subst_signature_msid msid mp sign)
-  | MTBfunsig _ -> []
-
-(* returns a resolver for kn that maps mbid to mp *)
-(* Desactivated until v8.2, waiting for the integration
-of "Parameter Inline". *)
-let resolver_of_environment mbid modtype mp env =
- let constants = constants_of_modtype env (MPbound mbid) modtype in
- let _ = List.map (fun (con,_) -> con,None) constants in 
- Mod_subst.make_resolver []
-
-
-let strengthen_const env mp l cb = 
- match cb.const_opaque, cb.const_body with
-  | false, Some _ -> cb
-  | true, Some _ 
-  | _, None -> 
-      let const = mkConst (make_con mp empty_dirpath l) 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)
-	}
+  match (eval_struct env modtype) with
+      SEBstruct (msid,sign) ->
+	constants_of_specification env mp
+	  (subst_signature_msid msid mp sign)
+    | SEBfunctor _ -> []
+    | _ -> anomaly "Modops:the evaluation of the structure failed "
+
+(* returns a resolver for kn that maps mbid to mp. We only keep
+   constants that have the inline flag *)
+and  resolver_of_environment mbid modtype mp alias env =
+ let constants = constants_of_modtype env (MPbound mbid) modtype.typ_expr in
+ let constants = List.map (fun (l,cb) -> (l,subst_const_body alias cb)) constants in
+ let rec make_resolve = function
+   | [] -> []
+   | (con,expecteddef)::r ->
+       let con' = replace_mp_in_con (MPbound mbid) mp con in
+       let con',_ = subst_con alias con' in
+  (*     let con' = replace_mp_in_con (MPbound mbid) mp con' in *)
+	 try
+	   if expecteddef.Declarations.const_inline then
+	     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
+		 (con,constr)::(make_resolve r)
+	     else make_resolve r
+	   else make_resolve r
+	 with Not_found -> error_no_such_label (con_label con')
+ in
+ let resolve = make_resolve constants in
+   Mod_subst.make_resolver resolve
 
-let strengthen_mind env mp l mib = match mib.mind_equiv with
-  | Some _ -> mib
-  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
     
-let rec strengthen_mtb env mp mtb = match scrape_modtype env mtb with
-  | MTBident _ -> anomaly "scrape_modtype does not work!"
-  | MTBfunsig _ -> mtb
-  | MTBsig (msid,sign) -> MTBsig (msid,strengthen_sig env msid sign mp)
-
-and strengthen_mod env mp msb = 
-  { msb_modtype = strengthen_mtb env mp msb.msb_modtype;
-    msb_equiv = begin match msb.msb_equiv with
-      | Some _ -> msb.msb_equiv
-      | None -> Some mp 
-    end ;
-    msb_constraints = msb.msb_constraints; }
-
+and strengthen_mtb env mp mtb =
+  let mtb1 = eval_struct env mtb in 
+  match  mtb1 with
+  | SEBfunctor _ -> mtb1
+  | SEBstruct (msid,sign) -> 
+      SEBstruct (msid,strengthen_sig env msid sign mp)
+  | _ -> anomaly "Modops:the evaluation of the structure failed "
+
+and strengthen_mod env mp mb = 
+  let mod_typ = type_of_mb env mb in
+    { mod_expr = mb.mod_expr;
+      mod_type = Some (strengthen_mtb env mp mod_typ);
+      mod_constraints = mb.mod_constraints;
+      mod_alias = mb.mod_alias;
+      mod_retroknowledge = mb.mod_retroknowledge}
+      
 and strengthen_sig env msid sign mp = match sign with
   | [] -> []
-  | (l,SPBconst cb) :: rest ->
-      let item' = l,SPBconst (strengthen_const env mp l cb) in
+  | (l,SFBconst cb) :: rest ->
+      let item' = l,SFBconst (strengthen_const env mp l cb) in
       let rest' = strengthen_sig env msid rest mp in
 	item'::rest'
-  | (l,SPBmind mib) :: rest ->
-      let item' = l,SPBmind (strengthen_mind env mp l mib) in
+  | (l,SFBmind mib) :: rest ->
+      let item' = l,SFBmind (strengthen_mind env mp l mib) in
       let rest' = strengthen_sig env msid rest mp in
 	item'::rest'
-  | (l,SPBmodule mb) :: rest ->
+  | (l,SFBmodule mb) :: rest ->
       let mp' = MPdot (mp,l) in
-      let item' = l,SPBmodule (strengthen_mod env mp' mb) in
-      let env' = add_module 
-		   (MPdot (MPself msid,l)) 
-		   (module_body_of_spec mb) 
-		   env 
-      in
+	let item' = l,SFBmodule (strengthen_mod env mp' mb) in
+	let env' = add_module 
+	  (MPdot (MPself msid,l)) mb env in
+        let rest' = strengthen_sig env' msid rest mp in
+	item':: rest'
+  | ((l,SFBalias (mp1,cst)) as item) :: rest ->
+      let env' = register_alias (MPdot(MPself msid,l)) mp1 env in
       let rest' = strengthen_sig env' msid rest mp in
-	item'::rest'
-  | (l,SPBmodtype mty as item) :: rest -> 
+	item::rest'
+  | (l,SFBmodtype mty as item) :: rest -> 
       let env' = add_modtype 
-		   (make_kn (MPself msid) empty_dirpath l) 
+		   (MPdot((MPself msid),l)) 
 		   mty
 		   env
       in
       let rest' = strengthen_sig env' msid rest mp in
 	item::rest'
 
+    
 let strengthen env mtb mp = strengthen_mtb env mp mtb
 
+
+let update_subst env mb mp =
+  match type_of_mb env mb with
+    | SEBstruct(msid,str) -> false, join_alias 
+	(subst_key (map_msid msid mp) mb.mod_alias)
+	(map_msid msid mp)
+    | _ -> true, mb.mod_alias
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 61761bb7..2d8b21ad 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli 9980 2007-07-12 13:32:37Z soubiran $ i*)
+(*i $Id: modops.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -20,35 +20,36 @@ open Mod_subst
 
 (* Various operations on modules and module types *)
 
-exception Circularity of string
-exception Not_equiv_path
-
-(* recursively unfold MTBdent module types *)
-val scrape_modtype : env -> module_type_body -> module_type_body
-
 (* make the environment entry out of type *)
 val module_body_of_type : module_type_body -> module_body
 
-val module_body_of_spec : module_specification_body -> module_body 
-
-val module_spec_of_body : module_body -> module_specification_body
-
+val  module_type_of_module : module_path option -> module_body -> 
+  module_type_body 
 
 val destr_functor : 
-  module_type_body -> mod_bound_id * module_type_body * module_type_body
-
+  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
 
 val subst_modtype : substitution -> module_type_body -> module_type_body
+val subst_structure : substitution -> structure_body -> structure_body
+
+val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
 
 val subst_signature_msid :
   mod_self_id -> module_path -> 
-  module_signature_body -> module_signature_body
+  structure_body -> structure_body
+
+val subst_structure : substitution -> structure_body -> structure_body
+
+(* Evaluation functions *)
+val eval_struct : env -> struct_expr_body -> struct_expr_body
+
+val type_of_mb : env -> module_body -> struct_expr_body
 
 (* [add_signature mp sign env] assumes that the substitution [msid]
    $\mapsto$ [mp] has already been performed (or is not necessary, like
    when [mp = MPself msid]) *)
 val add_signature : 
-  module_path -> module_signature_body -> env -> env
+  module_path -> structure_body -> env -> env
 
 (* adds a module and its components, but not the constraints *)
 val add_module :
@@ -56,22 +57,24 @@ val add_module :
 
 val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-val strengthen : env -> module_type_body -> module_path -> module_type_body
+val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body
+
+val update_subst : env -> module_body -> module_path -> bool * substitution
 
 val error_existing_label : label -> 'a
 
-val error_declaration_not_path : module_expr -> 'a
+val error_declaration_not_path : module_struct_entry -> 'a
 
-val error_application_to_not_path : module_expr -> 'a
+val error_application_to_not_path : module_struct_entry -> 'a
 
-val error_not_a_functor : module_expr -> '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 -> string -> string -> 'a
+val error_not_match : label -> structure_field_body -> 'a
   
 val error_incompatible_labels : label -> label -> 'a
 
@@ -79,7 +82,7 @@ val error_no_such_label : label -> 'a
 
 val error_result_must_be_signature : unit -> 'a
 
-val error_signature_expected : module_type_body -> 'a
+val error_signature_expected : struct_expr_body -> 'a
 
 val error_no_module_to_end : unit -> 'a 
 
@@ -99,11 +102,9 @@ val error_a_generative_module_expected : label -> 'a
 
 val error_local_context : label option -> 'a
 
-val error_circular_with_module : identifier -> 'a
-
-val error_circularity_in_subtyping : string->string->string-> 'a
-
 val error_no_such_label_sub : label->string->string->'a
 
 val resolver_of_environment :
- mod_bound_id -> module_type_body -> module_path -> env -> resolver
+  mod_bound_id -> module_type_body -> module_path -> substitution 
+  -> env -> resolver
+
diff --git a/kernel/names.ml b/kernel/names.ml
index 4273fe14..26bcc2eb 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml 9980 2007-07-12 13:32:37Z soubiran $ *)
+(* $Id: names.ml 10919 2008-05-11 22:04:26Z msozeau $ *)
 
 open Pp
 open Util
@@ -17,7 +17,7 @@ type identifier = string
 
 let id_ord = Pervasives.compare
 
-let id_of_string s = String.copy s
+let id_of_string s = check_ident s; String.copy s
 
 let string_of_id id = String.copy id
 
@@ -65,16 +65,15 @@ let repr_dirpath x = x
 let empty_dirpath = []
 
 let string_of_dirpath = function
-  | [] -> ""
-  | sl ->
-      String.concat "." (List.map string_of_id (List.rev sl))
+  | [] -> "<>"
+  | sl -> String.concat "." (List.map string_of_id (List.rev sl))
 
 
 let u_number = ref 0 
 type uniq_ident = int * string * dir_path
 let make_uid dir s = incr u_number;(!u_number,String.copy s,dir)
-let debug_string_of_uid (i,s,p) = 
-  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+ let debug_string_of_uid (i,s,p) =
+ "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
 let string_of_uid (i,s,p) = 
   string_of_dirpath p ^"."^s
 
@@ -83,20 +82,24 @@ module Umap = Map.Make(struct
 			 let compare = Pervasives.compare
 		       end)
 
+type label = string
 
 type mod_self_id = uniq_ident
 let make_msid = make_uid
 let debug_string_of_msid = debug_string_of_uid
+let refresh_msid (_,s,dir) = make_uid dir s
 let string_of_msid = string_of_uid
 let id_of_msid (_,s,_) = s
+let label_of_msid (_,s,_) = s
 
 type mod_bound_id = uniq_ident
 let make_mbid = make_uid
 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
+
 
-type label = string
 let mk_label l = l
 let string_of_label l = l
 
@@ -181,7 +184,7 @@ module Cmap = KNmap
 module Cpred = KNpred
 module Cset = KNset
 
-let default_module_name = id_of_string "If you see this, it's a bug"
+let default_module_name = "If you see this, it's a bug"
 
 let initial_dir = make_dirpath [default_module_name]
 
@@ -314,6 +317,11 @@ let hcons_names () =
 
 type transparent_state = Idpred.t * Cpred.t
 
+let empty_transparent_state = (Idpred.empty, Cpred.empty)
+let full_transparent_state = (Idpred.full, Cpred.full)
+let var_full_transparent_state = (Idpred.full, Cpred.empty)
+let cst_full_transparent_state = (Idpred.empty, Cpred.full)
+
 type 'a tableKey =
   | ConstKey of constant
   | VarKey of identifier
@@ -326,5 +334,3 @@ type inv_rel_key = int (* index in the [rel_context] part of environment
 
 type id_key = inv_rel_key tableKey
 
-
-
diff --git a/kernel/names.mli b/kernel/names.mli
index c9fef60a..c6f59048 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: names.mli 9558 2007-01-30 14:58:42Z soubiran $ i*)
+(*i $Id: names.mli 10919 2008-05-11 22:04:26Z msozeau $ i*)
 
 (*s Identifiers *)
 
@@ -42,13 +42,15 @@ val string_of_dirpath : dir_path -> string
 
 (*s Unique identifier to be used as "self" in structures and 
   signatures - invisible for users *)
-  
+type label 
 type mod_self_id
 
 (* The first argument is a file name - to prevent conflict between 
    different files *)
 val make_msid : dir_path -> string -> mod_self_id
 val id_of_msid : mod_self_id -> identifier
+val label_of_msid : mod_self_id -> label
+val refresh_msid : mod_self_id -> mod_self_id
 val debug_string_of_msid : mod_self_id -> string
 val string_of_msid : mod_self_id -> string
 
@@ -57,15 +59,15 @@ type mod_bound_id
 
 val make_mbid : dir_path -> string -> mod_bound_id
 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
 
 (*s Names of structure elements *)
-type label
+
 val mk_label : string -> label
 val string_of_label : label -> string
 
-
 val label_of_id : identifier -> label
 val id_of_label : label -> identifier
 
@@ -167,6 +169,11 @@ type 'a tableKey =
 
 type transparent_state = Idpred.t * Cpred.t
 
+val empty_transparent_state : transparent_state
+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} 
 			  of de Bruijn indice *)
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 947e4675..dd4d430a 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.ml 8810 2006-05-12 18:50:21Z barras $ *)
+(* $Id: pre_env.ml 10664 2008-03-14 11:27:37Z soubiran $ *)
 
 open Util
 open Names
@@ -26,34 +26,31 @@ type globals = {
   env_constants : constant_key Cmap.t;
   env_inductives : mutual_inductive_body KNmap.t;
   env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body KNmap.t }
+  env_modtypes : module_type_body MPmap.t;
+  env_alias : module_path MPmap.t }
 
 type stratification = {
   env_universes : universes;
   env_engagement : engagement option
 }
 
-type 'a val_kind =   
-  | VKvalue of values
-  | VKaxiom of 'a
-  | VKdef of constr
+type val_kind = 
+    | VKvalue of values * Idset.t
+    | VKnone
 
-type 'a lazy_val = 'a val_kind ref
+type lazy_val = val_kind ref
 
-type rel_val = inv_rel_key lazy_val
-
-type named_val = identifier lazy_val
-
-type named_vals = (identifier * named_val) list
+type named_vals = (identifier * lazy_val) list
 
 type env = {
   env_globals       : globals;
   env_named_context : named_context;
   env_named_vals    : named_vals;
   env_rel_context   : rel_context;
-  env_rel_val       : rel_val list;
+  env_rel_val       : lazy_val list;
   env_nb_rel        : int;
-  env_stratification : stratification }
+  env_stratification : stratification;
+  retroknowledge : Retroknowledge.retroknowledge }
 
 type named_context_val = named_context * named_vals
 
@@ -64,7 +61,8 @@ let empty_env = {
     env_constants = Cmap.empty;
     env_inductives = KNmap.empty;
     env_modules = MPmap.empty;
-    env_modtypes = KNmap.empty };
+    env_modtypes = MPmap.empty;
+    env_alias = MPmap.empty };
   env_named_context = empty_named_context;
   env_named_vals = [];
   env_rel_context = empty_rel_context;
@@ -72,24 +70,20 @@ let empty_env = {
   env_nb_rel = 0;
   env_stratification = {
     env_universes = initial_universes;
-    env_engagement = None } }
+    env_engagement = None };
+  retroknowledge = Retroknowledge.initial_retroknowledge }
 
 
 (* Rel context *)
 
 let nb_rel env = env.env_nb_rel
-
+  
 let push_rel d env =
-  let _,body,_ = d in
-  let rval =
-    match body with
-    | None -> ref (VKaxiom env.env_nb_rel)
-    | Some c -> ref (VKdef c)
-  in     
-  { env with
-    env_rel_context = add_rel_decl d env.env_rel_context;
-    env_rel_val = rval :: env.env_rel_val;
-    env_nb_rel = env.env_nb_rel + 1 }
+  let rval = ref VKnone in
+    { env with
+      env_rel_context = add_rel_decl d env.env_rel_context;
+      env_rel_val = rval :: env.env_rel_val;
+      env_nb_rel = env.env_nb_rel + 1 }
  
 let lookup_rel_val n env =
   try List.nth env.env_rel_val (n - 1)
@@ -101,16 +95,13 @@ let env_of_rel n env =
     env_rel_val = Util.list_skipn n env.env_rel_val;
     env_nb_rel = env.env_nb_rel - n
   }
-
+    
 (* Named context *)
 
 let push_named_context_val d (ctxt,vals) =
-  let id,body,_ = d in
-  let rval =
-    match body with
-    | None -> ref (VKaxiom id)
-    | Some c -> ref (VKdef c)
-  in Sign.add_named_decl d ctxt, (id,rval)::vals
+  let id,_,_ = d in
+  let rval = ref VKnone in
+    Sign.add_named_decl d ctxt, (id,rval)::vals
 
 exception ASSERT of Sign.rel_context
 
@@ -118,18 +109,14 @@ let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
   let id,body,_ = d in
-  let rval =
-    match body with
-    | None -> ref (VKaxiom id)
-    | Some c -> ref (VKdef c)
-  in
-  { env with  
-    env_named_context = Sign.add_named_decl d env.env_named_context;
-    env_named_vals =  (id,rval):: env.env_named_vals }
+  let rval = ref VKnone in
+    { env with  
+      env_named_context = Sign.add_named_decl d env.env_named_context;
+      env_named_vals =  (id,rval):: env.env_named_vals }
 
 let lookup_named_val id env =
-   snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
-  
+  snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
+    
 (* Warning all the names should be different *)
 let env_of_named id env = env
  
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 2642bc92..445f4e5f 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.mli 8810 2006-05-12 18:50:21Z barras $ *)
+(* $Id: pre_env.mli 10664 2008-03-14 11:27:37Z soubiran $ *)
 
 open Util
 open Names
@@ -26,34 +26,31 @@ type globals = {
   env_constants : constant_key Cmap.t;
   env_inductives : mutual_inductive_body KNmap.t;
   env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body KNmap.t }
+  env_modtypes : module_type_body MPmap.t;
+  env_alias : module_path MPmap.t }
 
 type stratification = {
   env_universes : universes;
   env_engagement : engagement option
 }
 
-type 'a val_kind =   
-  | VKvalue of values
-  | VKaxiom of 'a
-  | VKdef of constr
+type val_kind = 
+    | VKvalue of values * Idset.t
+    | VKnone
 
-type 'a lazy_val = 'a val_kind ref
+type lazy_val = val_kind ref
 
-type rel_val = inv_rel_key lazy_val
-
-type named_val = identifier lazy_val
-
-type named_vals = (identifier * named_val) list
+type named_vals = (identifier * lazy_val) list
 
 type env = {
-  env_globals       : globals;
-  env_named_context : named_context;
-  env_named_vals    : named_vals;
-  env_rel_context   : rel_context;
-  env_rel_val       : rel_val list;
-  env_nb_rel        : int;
-  env_stratification : stratification }
+    env_globals       : globals;
+    env_named_context : named_context;
+    env_named_vals    : named_vals;
+    env_rel_context   : rel_context;
+    env_rel_val       : lazy_val list;
+    env_nb_rel        : int;
+    env_stratification : stratification; 
+    retroknowledge : Retroknowledge.retroknowledge }
 
 type named_context_val = named_context * named_vals
 
@@ -65,14 +62,14 @@ val empty_env : env
 
 val nb_rel         : env -> int
 val push_rel       : rel_declaration -> env -> env
-val lookup_rel_val : int -> env -> rel_val
+val lookup_rel_val : int -> env -> lazy_val
 val env_of_rel     : int -> env -> env       
 (* 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 -> named_val
+val lookup_named_val : identifier -> env -> lazy_val
 val env_of_named     : identifier -> env -> env  
 (* Global constants *)
 
@@ -85,5 +82,3 @@ val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
 (* Find the ultimate inductive in the [mind_equiv] chain *)
 val scrape_mind : env -> mutual_inductive -> mutual_inductive
-
-
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 701020d0..43ef3a98 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
+(* $Id: reduction.ml 10930 2008-05-15 10:50:32Z barras $ *)
 
 open Util
 open Names
@@ -17,6 +17,12 @@ open Environ
 open Closure
 open Esubst
 
+let unfold_reference ((ids, csts), infos) k =
+  match k with
+    | VarKey id when not (Idpred.mem id ids) -> None
+    | ConstKey cst when not (Cpred.mem cst csts) -> None
+    | _ -> unfold_reference infos k
+	  
 let rec is_empty_stack = function
     [] -> true
   | Zupdate _::s -> is_empty_stack s
@@ -84,11 +90,11 @@ let pure_stack lfts stk =
 let nf_betaiota t =
   norm_val (create_clos_infos betaiota empty_env) (inject t)
 
-let whd_betaiotazeta env x =
+let whd_betaiotazeta x =
   match kind_of_term x with
     | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> x
-    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
+    | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x)
 
 let whd_betadeltaiota env t = 
   match kind_of_term t with
@@ -117,6 +123,7 @@ let beta_appvect c v =
 
 (* Conversion utility functions *)
 type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints
 
 exception NotConvertible
 exception NotConvertibleVect of int
@@ -144,18 +151,25 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
 
 (* Convertibility of sorts *)
 
+(* The sort cumulativity is
+
+    Prop <= Set <= Type 1 <= ... <= Type i <= ...
+
+    and this holds whatever Set is predicative or impredicative
+*)
+
 type conv_pb = 
   | CONV 
   | CUMUL
 
 let sort_cmp pb s0 s1 cuniv =
   match (s0,s1) with
-    | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible
-    | (Prop c1, Type u)  ->
-        (match pb with
-            CUMUL -> cuniv
-          | _ -> raise NotConvertible)
+    | (Prop c1, Prop c2) ->
+        if c1 = Null or c2 = Pos then cuniv   (* Prop <= Set *)
+        else raise NotConvertible
+    | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv
     | (Type u1, Type u2) ->
+	assert (is_univ_variable u2);
 	(match pb with
            | CONV -> enforce_eq u1 u2 cuniv
 	   | CUMUL -> enforce_geq u2 u1 cuniv)
@@ -166,19 +180,60 @@ let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
 
 let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
 
+let rec no_arg_available = function
+  | [] -> true
+  | Zupdate _ :: stk -> no_arg_available stk
+  | Zshift _ :: stk -> no_arg_available stk
+  | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk
+  | Zcase _ :: _ -> true
+  | Zfix _ :: _ -> true
+
+let rec no_nth_arg_available n = function
+  | [] -> true
+  | Zupdate _ :: stk -> no_nth_arg_available n stk
+  | Zshift _ :: stk -> no_nth_arg_available n stk
+  | Zapp v :: stk ->
+      let k = Array.length v in
+      if n >= k then no_nth_arg_available (n-k) stk
+      else false
+  | Zcase _ :: _ -> true
+  | Zfix _ :: _ -> true
+
+let rec no_case_available = function
+  | [] -> true
+  | Zupdate _ :: stk -> no_case_available stk
+  | Zshift _ :: stk -> no_case_available stk
+  | Zapp _ :: stk -> no_case_available stk
+  | Zcase _ :: _ -> false
+  | Zfix _ :: _ -> true
+
+let in_whnf (t,stk) =
+  match fterm_of t with
+    | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false
+    | FLambda _ -> no_arg_available stk
+    | FConstruct _ -> no_case_available stk
+    | FCoFix _ -> no_case_available stk
+    | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk
+    | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true
+    | FLOCKED -> assert false
 
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
 let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = 
-  Util.check_for_interrupt ();
-  eqappr cv_pb infos
-    (lft1, whd_stack infos term1 [])
-    (lft2, whd_stack infos term2 [])
-    cuniv
+  eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
-and eqappr cv_pb infos appr1 appr2 cuniv =
-  let (lft1,(hd1,v1)) = appr1 in
-  let (lft2,(hd2,v2)) = appr2 in
+and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
+  Util.check_for_interrupt ();
+  (* First head reduce both terms *)
+  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),
+       and st1 might not be in whnf anymore. If so, we iterate ccnv. *)
+    if in_whnf st1' then (st1',st2') else whd_both st1' st2' in
+  let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in
+  let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in
+  (* compute the lifts that apply to the head of the term (hd1 and hd2) *)
   let el1 = el_stack lft1 v1 in
   let el2 = el_stack lft2 v2 in
   match (fterm_of hd1, fterm_of hd2) with
@@ -216,17 +271,17 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
           let (app1,app2) =
             if Conv_oracle.oracle_order fl1 fl2 then
               match unfold_reference infos fl1 with
-                | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+                | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
                 | None ->
                     (match unfold_reference infos fl2 with
-                      | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                      | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
 		      | None -> raise NotConvertible)
             else
 	      match unfold_reference infos fl2 with
-                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
                 | None ->
                     (match unfold_reference infos fl1 with
-                    | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+                    | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
 		    | None -> raise NotConvertible) in
           eqappr cv_pb infos app1 app2 cuniv)
 
@@ -234,16 +289,17 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
     | (FFlex fl1, _)      ->
         (match unfold_reference infos fl1 with
            | Some def1 -> 
-	       eqappr cv_pb infos (lft1, whd_stack infos def1 v1) appr2 cuniv
+	       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 infos def2 v2) cuniv
+           | Some def2 ->
+	       eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
            | None -> raise NotConvertible)
 	
     (* other constructors *)
     | (FLambda _, FLambda _) ->
+        assert (is_empty_stack v1 && is_empty_stack v2);
         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
@@ -258,13 +314,13 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
      | (FInd ind1, FInd ind2) ->
-         if mind_equiv_infos infos ind1 ind2
+         if mind_equiv_infos (snd infos) ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
 
      | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
-	 if j1 = j2 && mind_equiv_infos infos ind1 ind2
+	 if j1 = j2 && mind_equiv_infos (snd infos) ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
@@ -299,25 +355,18 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
            convert_stacks infos lft1 lft2 v1 v2 u2
          else raise NotConvertible
 
-    (* Can happen because whd_stack on one arg may have side-effects
-       on the other arg and coulb be no more in hnf... *)
-    | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_)
-      | (FCLOS _, _) | (FLIFT _, _)) ->
-        eqappr cv_pb infos (lft1, whd_stack infos hd1 v1) appr2 cuniv
-
-    | ( (_, FLetIn _) | (_,FCases _) | (_,FApp _)
-      | (_,FCLOS _) | (_,FLIFT _)) ->
-        eqappr cv_pb infos (lft1, whd_stack infos hd1 v1) appr2 cuniv
-
-    (* Should not happen because whd_stack unlocks references *)
-    | ((FLOCKED,_) | (_,FLOCKED)) -> assert false
-
+     (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
+     | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
+       | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
+       | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
+    
+     (* In all other cases, terms are not convertible *)
      | _ -> raise NotConvertible
 
 and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
     (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
-    (mind_equiv_infos infos)
+    (mind_equiv_infos (snd infos))
     lft1 stk1 lft2 stk2 cuniv
 
 and convert_vect infos lft1 lft2 v1 v2 cuniv =
@@ -333,13 +382,19 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv =
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv cv_pb env t1 t2 =
-  let infos = create_clos_infos betaiotazeta env in
+let clos_fconv trans cv_pb env t1 t2 =
+  let infos = trans, create_clos_infos betaiotazeta env in
   ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
 
-let fconv cv_pb env t1 t2 =
+let trans_fconv reds cv_pb env t1 t2 =
   if eq_constr t1 t2 then Constraint.empty
-  else clos_fconv cv_pb env t1 t2
+  else clos_fconv reds cv_pb env t1 t2
+
+let trans_conv_cmp conv reds = trans_fconv reds conv
+let trans_conv reds = trans_fconv reds CONV
+let trans_conv_leq reds = trans_fconv reds CUMUL
+
+let fconv = trans_fconv (Idpred.full, Cpred.full)
 
 let conv_cmp = fconv
 let conv = fconv CONV
@@ -365,7 +420,7 @@ let vm_conv cv_pb env t1 t2 =
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
-      clos_fconv cv_pb env t1 t2
+      fconv cv_pb env t1 t2
   
 
 let default_conv = ref fconv 
@@ -377,7 +432,7 @@ let default_conv cv_pb env t1 t2 =
     !default_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
-      clos_fconv cv_pb env t1 t2
+      fconv cv_pb env t1 t2
   
 let default_conv_leq = default_conv CUMUL
 (*
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index a68e8697..3b9eb315 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -6,17 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
+(*i $Id: reduction.mli 10840 2008-04-23 21:29:34Z herbelin $ i*)
 
 (*i*)
 open Term
 open Environ
+open Closure
 (*i*)
 
 (************************************************************************)
 (*s Reduction functions *)
 
-val whd_betaiotazeta        : env -> constr -> constr
+val whd_betaiotazeta        : constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
 val whd_betadeltaiota_nolet : env -> constr -> constr
 
@@ -28,6 +29,7 @@ val nf_betaiota      : constr -> constr
 exception NotConvertible
 exception NotConvertibleVect of int
 type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints
 
 type conv_pb = CONV | CUMUL
 
@@ -37,6 +39,11 @@ 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           : constr trans_conversion_function
+val trans_conv_leq       : types trans_conversion_function
+
 val conv_cmp       : conv_pb -> constr conversion_function
 
 val conv           : constr conversion_function
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
new file mode 100644
index 00000000..7a1880be
--- /dev/null
+++ b/kernel/retroknowledge.ml
@@ -0,0 +1,279 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \V/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: retroknowledge.ml 10739 2008-04-01 14:45:20Z herbelin $ *)
+
+open Term
+open Names
+
+(* Type declarations, these types shouldn't be exported they are accessed
+   through specific functions. As being mutable and all it is wiser *)
+(* These types are put into two distinct categories: proactive and reactive.
+   Proactive information allows to find the name of a combinator, constructor
+   or inductive type handling a specific function.
+   Reactive information is, on the other hand, everything you need to know
+   about a specific name.*)
+
+(* aliased type for clarity purpose*)
+type entry =  (constr, types) kind_of_term
+
+(* the following types correspond to the different "things"
+   the kernel can learn about. These are the fields of the proactive knowledge*)
+type nat_field =
+  | NatType
+  | NatPlus
+  | NatTimes
+  
+type n_field = 
+  | NPositive
+  | NType
+  | NTwice
+  | NTwicePlusOne
+  | NPhi
+  | NPhiInv
+  | NPlus
+  | NTimes
+
+type int31_field = 
+  | Int31Bits
+  | Int31Type
+  | Int31Twice
+  | Int31TwicePlusOne
+  | Int31Phi
+  | Int31PhiInv
+  | Int31Plus
+  | Int31PlusC
+  | Int31PlusCarryC
+  | Int31Minus
+  | Int31MinusC
+  | Int31MinusCarryC
+  | Int31Times
+  | Int31TimesC
+  | Int31Div21
+  | Int31Div
+  | Int31AddMulDiv
+  | Int31Compare
+  | Int31Head0
+  | Int31Tail0
+
+type field =
+ (* | KEq
+  | KNat of nat_field
+  | KN of n_field *)
+  | KInt31 of string*int31_field
+
+
+(* record representing all the flags of the internal state of the kernel *)
+type flags = {fastcomputation : bool}
+
+
+
+
+
+(*A definition of maps from strings to pro_int31, to be able
+  to have any amount of coq representation for the 31bits integers *)
+module OrderedField =
+struct
+  type t = field
+  let compare = compare
+end
+
+module Proactive = Map.Make (OrderedField)
+
+
+type proactive = entry Proactive.t
+
+(* the reactive knowledge is represented as a functionaly map 
+   from the type of terms (actually it is the terms whose outermost
+   layer is unfolded (typically by Term.kind_of_term)) to the 
+   type reactive_end which is a record containing all the kind of reactive
+   information needed *)
+(* todo: because of the bug with output state, reactive_end should eventually
+   contain no function. A forseen possibility is to make it a map from
+   a finite type describing the fields to the field of proactive retroknowledge
+   (and then to make as many functions as needed in environ.ml) *)
+
+module OrderedEntry =
+struct
+  type t = entry
+  let compare = compare
+end
+
+module Reactive = Map.Make (OrderedEntry)
+
+type reactive_end = {(*information required by the compiler of the VM *)
+  vm_compiling :
+      (*fastcomputation flag -> continuation -> result *)
+      (bool->Cbytecodes.comp_env->constr array ->
+       int->Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  vm_constant_static :
+      (*fastcomputation flag -> constructor -> args -> result*)
+      (bool->constr array->Cbytecodes.structured_constant)
+      option;
+  vm_constant_dynamic :
+      (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *)
+      (bool->Cbytecodes.comp_env->Cbytecodes.block array->int->
+         Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  (* fastcomputation flag -> cont -> result *)
+  vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option;
+  (* tag (= compiled int for instance) -> result *)
+  vm_decompile_const : (int -> Term.constr) option}
+
+
+
+and reactive = reactive_end Reactive.t
+
+and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive}
+
+(* 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
+
+
+(*initialisation*)
+let initial_flags = 
+      {fastcomputation = true;}
+
+let initial_proactive = 
+  (Proactive.empty:proactive)
+
+let initial_reactive = 
+  (Reactive.empty:reactive)
+
+let initial_retroknowledge =
+  {flags = initial_flags; 
+   proactive = initial_proactive; 
+   reactive = initial_reactive }
+
+let empty_reactive_end =
+  { vm_compiling = None ;
+    vm_constant_static = None;
+    vm_constant_dynamic = None;
+    vm_before_match = None;
+    vm_decompile_const = None }
+
+
+
+
+(* acces functions for proactive retroknowledge *)
+let add_field knowledge field value =
+  {knowledge with proactive = Proactive.add field value knowledge.proactive}
+
+let mem knowledge field =
+  Proactive.mem field knowledge.proactive
+
+let remove knowledge field =
+  {knowledge with proactive = Proactive.remove field knowledge.proactive}
+
+let find knowledge field =
+  Proactive.find field knowledge.proactive
+
+
+
+
+
+(*access functions for reactive retroknowledge*)
+
+(* used for compiling of functions (add, mult, etc..) *)
+let get_vm_compiling_info knowledge key = 
+  match (Reactive.find key knowledge.reactive).vm_compiling
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
+
+(* used for compilation of fully applied constructors *)
+let get_vm_constant_static_info knowledge key =
+  match (Reactive.find key knowledge.reactive).vm_constant_static
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
+
+(* used for compilation of partially applied constructors *)
+let get_vm_constant_dynamic_info knowledge key =
+  match (Reactive.find key knowledge.reactive).vm_constant_dynamic
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
+
+let get_vm_before_match_info knowledge key = 
+  match (Reactive.find key knowledge.reactive).vm_before_match
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
+
+let get_vm_decompile_constant_info knowledge key = 
+  match (Reactive.find key knowledge.reactive).vm_decompile_const
+  with
+    | None -> raise Not_found
+    | Some f -> f
+  
+
+
+(* functions manipulating reactive knowledge *)
+let add_vm_compiling_info knowledge value nfo =
+  {knowledge with reactive =
+   try
+     Reactive.add value
+       {(Reactive.find value (knowledge.reactive)) with vm_compiling = Some nfo}
+       knowledge.reactive
+   with Not_found ->
+     Reactive.add value {empty_reactive_end with vm_compiling = Some nfo}
+       knowledge.reactive
+  }
+
+let add_vm_constant_static_info knowledge value nfo =
+  {knowledge with reactive =
+   try
+     Reactive.add value
+       {(Reactive.find value (knowledge.reactive)) with vm_constant_static = Some nfo}
+       knowledge.reactive
+   with Not_found ->
+     Reactive.add value {empty_reactive_end with vm_constant_static = Some nfo}
+       knowledge.reactive
+  }
+
+let add_vm_constant_dynamic_info knowledge value nfo =
+  {knowledge with reactive =
+   try
+     Reactive.add value
+       {(Reactive.find value (knowledge.reactive)) with vm_constant_dynamic = Some nfo}
+       knowledge.reactive
+   with Not_found ->
+     Reactive.add value {empty_reactive_end with vm_constant_dynamic = Some nfo}
+       knowledge.reactive
+  }
+
+let add_vm_before_match_info knowledge value nfo =
+  {knowledge with reactive =
+   try
+     Reactive.add value
+       {(Reactive.find value (knowledge.reactive)) with vm_before_match = Some nfo}
+       knowledge.reactive
+   with Not_found ->
+     Reactive.add value {empty_reactive_end with vm_before_match = Some nfo}
+       knowledge.reactive
+  }
+
+let add_vm_decompile_constant_info knowledge value nfo =
+  {knowledge with reactive =
+   try
+     Reactive.add value
+       {(Reactive.find value (knowledge.reactive)) with vm_decompile_const = Some nfo}
+       knowledge.reactive
+   with Not_found ->
+     Reactive.add value {empty_reactive_end with vm_decompile_const = Some nfo}
+       knowledge.reactive
+  }
+
+let clear_info knowledge value =
+  {knowledge with reactive = Reactive.remove value knowledge.reactive}
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
new file mode 100644
index 00000000..ee3fccd5
--- /dev/null
+++ b/kernel/retroknowledge.mli
@@ -0,0 +1,154 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: retroknowledge.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
+
+(*i*)
+open Names
+open Term
+(*i*)
+
+type retroknowledge
+
+(* aliased type for clarity purpose*)
+type entry =  (constr, types) kind_of_term
+
+(* the following types correspond to the different "things"
+   the kernel can learn about.*)
+type nat_field =
+  | NatType
+  | NatPlus
+  | NatTimes
+  
+type n_field = 
+  | NPositive
+  | NType
+  | NTwice
+  | NTwicePlusOne
+  | NPhi
+  | NPhiInv
+  | NPlus
+  | NTimes
+
+type int31_field = 
+  | Int31Bits
+  | Int31Type
+  | Int31Twice
+  | Int31TwicePlusOne
+  | Int31Phi
+  | Int31PhiInv
+  | Int31Plus
+  | Int31PlusC
+  | Int31PlusCarryC
+  | Int31Minus
+  | Int31MinusC
+  | Int31MinusCarryC
+  | Int31Times
+  | Int31TimesC
+  | Int31Div21
+  | Int31Div
+  | Int31AddMulDiv
+  | Int31Compare
+  | Int31Head0
+  | Int31Tail0
+
+type field =
+(*  | 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
+   the possibility of unregistering or changing the flag is under study *)
+type action =
+    | RKRegister of field*entry
+
+
+(* initial value for retroknowledge *)
+val initial_retroknowledge : retroknowledge
+
+
+(* 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 *)
+val get_vm_compiling_info  : retroknowledge -> entry -> Cbytecodes.comp_env ->
+                             constr array -> 
+                             int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes
+(*Given an identifier id (usually Construct _)
+   and its argument array, returns a function that tries an ad-hoc optimisated
+   compilation (in the case of the 31-bit integers it means compiling them
+   directly into an integer)
+   raises Not_found if id should be compiled as usual, and expectingly
+   CBytecodes.NotClosed if the term is not a closed constructor pattern 
+   (a constant for the compiler) *)
+val get_vm_constant_static_info : retroknowledge -> entry ->
+                                   constr array ->
+                                   Cbytecodes.structured_constant
+
+(*Given an identifier id (usually Construct _ )
+   its argument array and a continuation, returns the compiled version
+   of id+args+cont when id has a specific treatment (in the case of
+   31-bit integers, that would be the dynamic compilation into integers)
+   or raises Not_found if id should be compiled as usual *)
+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 
+   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 
+   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 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
+   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 -> 
+                            (bool -> Cbytecodes.comp_env -> constr array -> int ->
+                            Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
+                            retroknowledge
+val add_vm_constant_static_info : retroknowledge-> entry -> 
+                                  (bool->constr array->
+                                      Cbytecodes.structured_constant) ->
+                                  retroknowledge
+val add_vm_constant_dynamic_info : retroknowledge-> entry -> 
+                                   (bool -> Cbytecodes.comp_env -> 
+                                   Cbytecodes.block array -> int -> 
+                                   Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
+                                   retroknowledge
+val add_vm_before_match_info : retroknowledge -> entry ->
+                              (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) ->
+                              retroknowledge
+
+val add_vm_decompile_constant_info : retroknowledge -> entry -> 
+                                    (int -> constr) -> retroknowledge
+                                      
+
+val clear_info : retroknowledge-> entry -> retroknowledge
+
+
+
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 5f01613c..6906fb29 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml 10276 2007-10-30 11:37:54Z barras $ *)
+(* $Id: safe_typing.ml 11170 2008-06-25 08:31:04Z soubiran $ *)
 
 open Util
 open Names
@@ -25,6 +25,7 @@ open Term_typing
 open Modops
 open Subtyping
 open Mod_typing
+open Mod_subst
 
 type modvariant = 
   | NONE 
@@ -37,7 +38,8 @@ type module_info =
       modpath : module_path;
       seed : dir_path; (* the "seed" of unique identifier generator *)
       label : label;
-      variant : modvariant}
+      variant : modvariant;
+      alias_subst : substitution}
 
 let check_label l labset = 
   if Labset.mem l labset then error_existing_label l
@@ -54,12 +56,12 @@ type safe_environment =
       env : env;
       modinfo : module_info;
       labset : Labset.t;
-      revsign : module_signature_body;
-      revstruct : module_structure_body;
+      revstruct : structure_body;
       univ : Univ.constraints;
       engagement : engagement option;
       imports : library_info list;
-      loads : (module_path * module_body) list }
+      loads : (module_path * module_body) list;
+      local_retroknowledge : Retroknowledge.action list}
 
 (*
   { old = senv.old;
@@ -81,19 +83,75 @@ let rec empty_environment =
       modpath = initial_path;
       seed = initial_dir;
       label = mk_label "_";
-      variant = NONE};
+      variant = NONE;
+      alias_subst = empty_subst};
     labset = Labset.empty;
-    revsign = [];
     revstruct = [];
     univ = Univ.Constraint.empty;
     engagement = None;
     imports = [];
-    loads = [] }
+    loads = [];
+    local_retroknowledge = [] }
 
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
 
 
+
+
+
+
+
+let add_constraints cst senv = 
+  {senv with
+    env = Environ.add_constraints cst senv.env;
+    univ = Univ.Constraint.union cst senv.univ }
+
+
+(*spiwack: functions for safe retroknowledge *)
+
+(* terms which are closed under the environnement env, i.e
+   terms which only depends on constant who are themselves closed *)
+let closed env term = 
+  ContextObjectMap.is_empty (assumptions env term)
+
+(* the set of safe terms in an environement any recursive set of
+   terms who are known not to prove inconsistent statement. It should
+   include at least all the closed terms. But it could contain other ones
+   like the axiom of excluded middle for instance *)
+let safe =
+  closed
+
+
+
+(* universal lifting, used for the "get" operations mostly *)
+let retroknowledge f senv = 
+  Environ.retroknowledge f (env_of_senv senv)
+
+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 = 
+      Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
+  }
+
+(* spiwack : currently unused *)
+let unregister senv field  =
+  (*spiwack: todo: do things properly or delete *)
+  {senv with env = Environ.unregister senv.env field}
+(* /spiwack *)
+
+
+
+
+
+
+
+
+
+
 (* Insertion of section variables. They are now typed before being
    added to the environment. *)
 
@@ -111,15 +169,15 @@ let safe_push_named (id,_,_ as d) env =
 
 let push_named_def (id,b,topt) senv =
   let (c,typ,cst) = translate_local_def senv.env (b,topt) in
-  let env' = add_constraints cst senv.env in
-  let env'' = safe_push_named (id,Some c,typ) env' in
-  (cst, {senv with env=env''})
+  let senv' = add_constraints cst senv in
+  let env'' = safe_push_named (id,Some c,typ) senv'.env in
+  (cst, {senv' with env=env''})
 
 let push_named_assum (id,t) senv =
   let (t,cst) = translate_local_assum senv.env t in
-  let env' = add_constraints cst senv.env in
-  let env'' = safe_push_named (id,None,t) env' in
-  (cst, {senv with env=env''})
+  let senv' = add_constraints cst senv in
+  let env'' = safe_push_named (id,None,t) senv'.env in
+  (cst, {senv' with env=env''})
 
 
 (* Insertion of constants and parameters in environment. *)
@@ -154,18 +212,18 @@ let add_constant dir l decl senv =
 	  let cb = translate_recipe senv.env kn r in
 	    if dir = empty_dirpath then hcons_constant_body cb else cb
   in
-  let env' = Environ.add_constraints cb.const_constraints senv.env in
-  let env'' = Environ.add_constant kn cb env' in
-    kn, { old = senv.old;
+  let senv' = add_constraints cb.const_constraints senv in
+  let env'' = Environ.add_constant kn cb senv'.env in
+    kn, { old = senv'.old;
 	  env = env'';
-	  modinfo = senv.modinfo;
-	  labset = Labset.add l senv.labset;
-	  revsign = (l,SPBconst cb)::senv.revsign;
-	  revstruct = (l,SEBconst cb)::senv.revstruct;
-          univ = senv.univ;
-          engagement = senv.engagement;
-	  imports = senv.imports;
-	  loads = senv.loads }
+	  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 }
     
 
 (* Insertion of inductive types. *)
@@ -182,67 +240,99 @@ let add_mind dir l mie senv =
     (* TODO: when we will allow reorderings we will have to verify 
        all labels *)
   let mib = translate_mind senv.env mie in
-  let env' = Environ.add_constraints mib.mind_constraints senv.env in
+  let senv' = add_constraints mib.mind_constraints senv in
   let kn = make_kn senv.modinfo.modpath dir l in
-  let env'' = Environ.add_mind kn mib env' in
-  kn, { old = senv.old;
+  let env'' = Environ.add_mind kn mib senv'.env in
+  kn, { old = senv'.old;
 	env = env'';
-	modinfo = senv.modinfo;
-	labset = Labset.add l senv.labset;  (* TODO: the same as above *)
-	revsign = (l,SPBmind mib)::senv.revsign;
-	revstruct = (l,SEBmind mib)::senv.revstruct;
-        univ = senv.univ;
-        engagement = senv.engagement;
-	imports = senv.imports;
-	loads = senv.loads }
-
+	modinfo = senv'.modinfo;
+	labset = Labset.add l senv'.labset;  (* TODO: the same as above *)
+	revstruct = (l,SFBmind mib)::senv'.revstruct;
+        univ = senv'.univ;
+        engagement = senv'.engagement;
+	imports = senv'.imports;
+	loads = senv'.loads;
+        local_retroknowledge = senv'.local_retroknowledge }
 
 (* Insertion of module types *)
 
 let add_modtype l mte senv = 
   check_label l senv.labset; 
-  let mtb = translate_modtype senv.env mte in
-  let env' = add_modtype_constraints senv.env mtb in
-  let kn = make_kn senv.modinfo.modpath empty_dirpath l in
-  let env'' = Environ.add_modtype kn mtb env' in
-  kn, { old = senv.old;
+  let mtb_expr,sub = translate_struct_entry senv.env mte  in
+  let mtb = { typ_expr = mtb_expr;
+	      typ_strength = None;
+	      typ_alias = sub} in
+  let senv' = add_constraints 
+    (struct_expr_constraints mtb_expr) senv in
+  let mp = MPdot(senv.modinfo.modpath, l) 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;
-	revsign = (l,SPBmodtype mtb)::senv.revsign;
-	revstruct = (l,SEBmodtype mtb)::senv.revstruct;
-        univ = senv.univ;
-        engagement = senv.engagement;
-	imports = senv.imports;
-	loads = senv.loads }
-
+	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 }
 
 
 (* full_add_module adds module with universes and constraints *)
-let full_add_module mp mb env =
-  let env = add_module_constraints env mb in
-  let env = Modops.add_module mp mb env in
-    env
-
+let full_add_module mp mb senv =
+  let senv = add_constraints (module_constraints mb) senv in
+  let env = Modops.add_module mp mb senv.env in
+    {senv with env = env}
+      
 (* Insertion of modules *)
-
+      
 let add_module l me senv = 
   check_label l senv.labset; 
   let mb = translate_module senv.env me in
-  let mspec = module_spec_of_body mb in
   let mp = MPdot(senv.modinfo.modpath, l) in
-  let env' = full_add_module mp mb senv.env in
-  mp, { old = senv.old;
+  let senv' = full_add_module mp mb senv in
+  let is_functor,sub = Modops.update_subst senv'.env mb mp in
+  mp, { old = senv'.old;
+	env = senv'.env;
+	modinfo = 
+      if is_functor then
+	senv'.modinfo
+      else
+	{senv'.modinfo with 
+	   alias_subst = join senv'.modinfo.alias_subst sub};
+	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 }
+    
+let add_alias l mp senv =
+  check_label l senv.labset; 
+  let mp' = MPdot(senv.modinfo.modpath, l) in
+  let mp1 = scrape_alias mp senv.env in
+    (* we get all updated alias substitution {mp1.K\M}  that comes from mp1 *)
+  let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in
+    (* transformation of {mp1.K\M} to {mp.K\M}*)
+  let sub = update_subst sub (map_mp mp' mp1) in
+   (* transformation of {mp.K\M}  to {mp.K\M'} where M'=M{mp1\mp'}*)
+  let sub = join_alias sub (map_mp mp' mp1) in
+    (* we add the alias substitution  *)
+  let sub = add_mp mp' mp1 sub in
+  let env' = register_alias mp' mp senv.env in
+    mp', { old = senv.old;
 	env = env';
-	modinfo = senv.modinfo;
+	modinfo = { senv.modinfo with 
+		      alias_subst = join 
+	    senv.modinfo.alias_subst sub};
 	labset = Labset.add l senv.labset;
-	revsign = (l,SPBmodule mspec)::senv.revsign;
-	revstruct = (l,SEBmodule mb)::senv.revstruct;
+	revstruct = (l,SFBalias (mp,None))::senv.revstruct;
         univ = senv.univ;
         engagement = senv.engagement;
 	imports = senv.imports;
-	loads = senv.loads }
-
+	loads = senv.loads;
+        local_retroknowledge = senv.local_retroknowledge }
 
 (* Interactive modules *)
 
@@ -254,96 +344,213 @@ let start_module l senv =
 		  modpath = mp;
 		  seed = senv.modinfo.seed;
 		  label = l;
-		  variant = STRUCT [] }
+		  variant = STRUCT [];
+		  alias_subst = empty_subst}
   in
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
 	labset = Labset.empty;
-	revsign = [];
 	revstruct = [];
         univ = Univ.Constraint.empty;
         engagement = None;
 	imports = senv.imports;
-	loads = [] }
+	loads = [];
+	(* spiwack : not sure, but I hope it's correct *)
+        local_retroknowledge = [] }
 
 let end_module l restype senv = 
   let oldsenv = senv.old in
   let modinfo = senv.modinfo in
-  let restype = option_map (translate_modtype senv.env) restype in
-  let params = 
+  let restype = Option.map (translate_struct_entry senv.env) restype in
+  let params,is_functor = 
     match modinfo.variant with
       | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
-      | STRUCT params -> params
+      | 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;
-  let functorize_type tb = 
+  let functorize_struct tb = 
     List.fold_left
-      (fun mtb (arg_id,arg_b) -> MTBfunsig (arg_id,arg_b,mtb))
+      (fun mtb (arg_id,arg_b) -> 
+	SEBfunctor(arg_id,arg_b,mtb))
       tb
       params
   in
-  let auto_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
-  let mtb, mod_user_type, cst = 
+   let auto_tb = 
+     SEBstruct (modinfo.msid, List.rev senv.revstruct)
+  in
+  let mod_typ,subst,cst = 
     match restype with
-      | None -> functorize_type auto_tb, None, Constraint.empty
-      | Some res_tb -> 
-	  let cst = check_subtypes senv.env auto_tb res_tb in
-	  let mtb = functorize_type res_tb in
-	    mtb, Some mtb, cst
+      | None ->  None,modinfo.alias_subst,Constraint.empty
+      | Some (res_tb,subst) -> 
+	  let cst = check_subtypes senv.env
+	    {typ_expr = auto_tb;
+	     typ_strength = None;
+	     typ_alias = modinfo.alias_subst}
+	    {typ_expr = res_tb;
+	     typ_strength = None;
+	     typ_alias = subst} in
+	  let mtb = functorize_struct res_tb in
+	    Some mtb,subst,cst
   in
+  let mexpr = functorize_struct auto_tb in
   let cst = Constraint.union cst senv.univ in
-  let mexpr = 
-    List.fold_left
-      (fun mtb (arg_id,arg_b) -> MEBfunctor (arg_id,arg_b,mtb))
-      (MEBstruct (modinfo.msid, List.rev senv.revstruct)) 
-      params
-  in
   let mb = 
     { mod_expr = Some mexpr;
-      mod_user_type = mod_user_type;
-      mod_type = mtb;
-      mod_equiv = None;
-      mod_constraints = cst }
-  in
-  let mspec = 
-    { msb_modtype = mtb;
-      msb_equiv = None;
-      msb_constraints = Constraint.empty } 
+      mod_type = mod_typ;
+      mod_constraints = cst;
+      mod_alias = subst;
+      mod_retroknowledge = senv.local_retroknowledge }
   in
   let mp = MPdot (oldsenv.modinfo.modpath, l) in
   let newenv = oldsenv.env in
   let newenv = set_engagement_opt senv.engagement newenv in
-  let newenv = 
+  let senv'= {senv with env=newenv} in
+  let senv' = 
     List.fold_left
       (fun env (mp,mb) -> full_add_module mp mb env) 
-      newenv
-      senv.loads
+      senv'
+      (List.rev senv'.loads)
   in
+  let newenv = Environ.add_constraints cst senv'.env in
   let newenv = 
-    full_add_module mp mb newenv
+    Modops.add_module mp mb newenv
   in 
-  mp, { old = oldsenv.old;
+  let is_functor,subst = Modops.update_subst newenv mb mp in
+  let newmodinfo = 
+    if is_functor then
+      oldsenv.modinfo
+    else
+      { oldsenv.modinfo with 
+	  alias_subst = join 
+	  oldsenv.modinfo.alias_subst 
+	  subst };
+  in
+    mp, { old = oldsenv.old;
 	env = newenv;
-	modinfo = oldsenv.modinfo;
+	modinfo = newmodinfo;
 	labset = Labset.add l oldsenv.labset;
-	revsign = (l,SPBmodule mspec)::oldsenv.revsign;
-	revstruct = (l,SEBmodule mb)::oldsenv.revstruct;
-        univ = oldsenv.univ;
+	revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
+        univ = Univ.Constraint.union senv'.univ oldsenv.univ;
         (* engagement is propagated to the upper level *)
-        engagement = senv.engagement;
-	imports = senv.imports;
-	loads = senv.loads@oldsenv.loads }
-
-
+        engagement = senv'.engagement;
+	imports = senv'.imports;
+	loads = senv'.loads@oldsenv.loads;
+	local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge }
+
+
+(* Include for module and module type*)
+ let add_include me senv =
+   let struct_expr,_ =  translate_struct_entry senv.env me in
+   let senv = add_constraints (struct_expr_constraints struct_expr) senv in
+   let msid,str = match (eval_struct senv.env struct_expr) with
+     | SEBstruct(msid,str_l) -> msid,str_l
+     | _ -> error ("You cannot Include a higher-order Module or Module Type" )
+   in
+   let mp_sup = senv.modinfo.modpath in
+   let str1 = subst_signature_msid msid mp_sup str in
+   let add senv (l,elem)  = 
+     check_label l senv.labset;
+     match elem with
+       | SFBconst cb ->
+	   let con = make_con mp_sup empty_dirpath l 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 ->
+	   let kn = make_kn mp_sup empty_dirpath l in
+	   let senv' = add_constraints mib.mind_constraints senv in
+	   let env'' = Environ.add_mind kn mib senv'.env in
+	     { old = senv'.old;
+	       env = env'';
+	       modinfo = senv'.modinfo;
+	       labset = Labset.add l 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 mp = MPdot(senv.modinfo.modpath, l) in
+	   let is_functor,sub = Modops.update_subst senv.env mb mp in
+	   let senv' = full_add_module mp mb senv in
+	     { old = senv'.old;
+	       env = senv'.env;
+	       modinfo = 
+		 if is_functor then
+		   senv'.modinfo
+		 else
+		   {senv'.modinfo with 
+		      alias_subst = join senv'.modinfo.alias_subst sub};
+	       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 }
+       | SFBalias (mp',cst) ->
+	   let env' = Option.fold_right 
+	     Environ.add_constraints cst senv.env in
+	   let mp = MPdot(senv.modinfo.modpath, l) in
+	   let mp1 = scrape_alias mp' senv.env in
+	   let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in
+	   let sub = update_subst sub (map_mp mp mp1) in
+	   let sub = join_alias sub (map_mp mp mp1) in
+	   let sub = add_mp mp mp1 sub in
+	   let env' = register_alias mp mp' env' in
+	     { old = senv.old;
+	       env = env';
+	       modinfo =  { senv.modinfo with 
+			      alias_subst = join 
+		   senv.modinfo.alias_subst sub};
+	       labset = Labset.add l senv.labset;
+	       revstruct = (l,SFBalias (mp',cst))::senv.revstruct;
+               univ = senv.univ;
+               engagement = senv.engagement;
+	       imports = senv.imports;
+	       loads = senv.loads;
+               local_retroknowledge = senv.local_retroknowledge }
+       | SFBmodtype mtb ->
+	   let env' = add_modtype_constraints senv.env mtb in
+	   let mp = MPdot(senv.modinfo.modpath, l) in
+	   let env'' = Environ.add_modtype mp mtb 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 }
+   in
+     List.fold_left add senv str1
+	   
 (* Adding parameters to modules or module types *)
 
 let add_module_parameter mbid mte senv =
-  if senv.revsign <> [] or senv.revstruct <> [] or senv.loads <> [] then
+  if  senv.revstruct <> [] or senv.loads <> [] then
     anomaly "Cannot add a module parameter to a non empty module";
-  let mtb = translate_modtype senv.env mte in
-  let env = full_add_module (MPbound mbid) (module_body_of_type mtb) senv.env 
+  let mtb_expr,sub = translate_struct_entry senv.env mte in
+  let mtb = {typ_expr = mtb_expr;
+	    typ_strength = None;
+	    typ_alias = sub} in
+  let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv 
   in
   let new_variant = match senv.modinfo.variant with
     | STRUCT params -> STRUCT ((mbid,mtb) :: params)
@@ -352,15 +559,15 @@ let add_module_parameter mbid mte senv =
 	anomaly "Module parameters can only be added to modules or signatures"
   in
   { old = senv.old;
-    env = env;
+    env = senv.env;
     modinfo = { senv.modinfo with variant = new_variant };
     labset = senv.labset;
-    revsign = [];
     revstruct = [];
     univ = senv.univ;
     engagement = senv.engagement;
     imports = senv.imports;
-    loads = [] }
+    loads = [];
+    local_retroknowledge = senv.local_retroknowledge }
 
 
 (* Interactive module types *)
@@ -373,18 +580,20 @@ let start_modtype l senv =
 		  modpath = mp;
 		  seed = senv.modinfo.seed;
 		  label = l;
-		  variant = SIG [] }
+		  variant = SIG [];
+		  alias_subst = empty_subst }
   in
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
 	labset = Labset.empty;
-	revsign = [];
 	revstruct = [];
         univ = Univ.Constraint.empty;
         engagement = None;
 	imports = senv.imports;
-	loads = [] }
+	loads = [] ;
+	(* spiwack: not 100% sure, but I think it should be like that *)
+        local_retroknowledge = []}
 
 let end_modtype l senv = 
   let oldsenv = senv.old in
@@ -396,52 +605,55 @@ let end_modtype l senv =
   in
   if l <> modinfo.label then error_incompatible_labels l modinfo.label;
   if not (empty_context senv.env) then error_local_context None;
-  let res_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
-  let mtb = 
+  let auto_tb = 
+     SEBstruct (modinfo.msid, List.rev senv.revstruct)
+  in
+  let mtb_expr = 
     List.fold_left
-      (fun mtb (arg_id,arg_b) -> MTBfunsig (arg_id,arg_b,mtb))
-      res_tb
+      (fun mtb (arg_id,arg_b) -> 
+	 SEBfunctor(arg_id,arg_b,mtb))
+      auto_tb
       params
   in
-  let kn = make_kn oldsenv.modinfo.modpath empty_dirpath l in
+  let mp = MPdot (oldsenv.modinfo.modpath, l) in
   let newenv = oldsenv.env in
   (* since universes constraints cannot be stored in the modtype,
      they are propagated to the upper level *)
-  let newenv = add_constraints senv.univ  newenv in
+  let newenv = Environ.add_constraints senv.univ  newenv in
   let newenv = set_engagement_opt senv.engagement newenv in
-  let newenv = 
+  let senv = {senv with env=newenv} in
+  let senv = 
     List.fold_left
       (fun env (mp,mb) -> full_add_module mp mb env) 
-      newenv
-      senv.loads
-  in
-  let newenv = 
-    add_modtype_constraints newenv mtb 
+      senv
+      (List.rev senv.loads)
   in
+  let subst = senv.modinfo.alias_subst in
+  let mtb = {typ_expr = mtb_expr;
+	    typ_strength = None;
+	    typ_alias = subst} in
   let newenv = 
-    Environ.add_modtype kn mtb newenv
+    Environ.add_modtype mp mtb senv.env
   in 
-  kn, { old = oldsenv.old;
-	env = newenv;
+    mp, { old = oldsenv.old;
+	  env = newenv;
 	modinfo = oldsenv.modinfo;
 	labset = Labset.add l oldsenv.labset;
-	revsign = (l,SPBmodtype mtb)::oldsenv.revsign;
-	revstruct = (l,SEBmodtype mtb)::oldsenv.revstruct;
+	revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
         univ = Univ.Constraint.union senv.univ oldsenv.univ;
         engagement = senv.engagement;
 	imports = senv.imports;
-	loads = senv.loads@oldsenv.loads }
+	loads = senv.loads@oldsenv.loads;
+        (* spiwack : if there is a bug with retroknowledge in nested modules
+                     it's likely to come from here *)
+        local_retroknowledge = 
+                   senv.local_retroknowledge@oldsenv.local_retroknowledge}
   
 
 let current_modpath senv = senv.modinfo.modpath
 let current_msid senv = senv.modinfo.msid
 
 
-let add_constraints cst senv = 
-  {senv with
-    env = Environ.add_constraints cst senv.env;
-    univ = Univ.Constraint.union cst senv.univ }
-
 (* Check that the engagement expected by a library matches the initial one *)
 let check_engagement env c =
   match Environ.engagement env, c with
@@ -460,12 +672,11 @@ let set_engagement c senv =
 type compiled_library = 
     dir_path * module_body * library_info list * engagement option
 
-
 (* We check that only initial state Require's were performed before 
    [start_library] was called *)
 
 let is_empty senv =
-  senv.revsign = [] &&
+  senv.revstruct = [] &&
   senv.modinfo.msid = initial_msid &&
   senv.modinfo.variant = NONE
 
@@ -484,18 +695,20 @@ let start_library dir senv =
 		  modpath = mp;
 		  seed = dir;
 		  label = l;
-		  variant = LIBRARY dir }
+		  variant = LIBRARY dir;
+		  alias_subst = empty_subst }
   in
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
 	labset = Labset.empty;
-	revsign = [];
 	revstruct = [];
         univ = Univ.Constraint.empty;
         engagement = None;
 	imports = senv.imports;
-	loads = [] }
+	loads = [];
+        local_retroknowledge = [] }
+
 
 
 let export senv dir = 
@@ -511,11 +724,11 @@ let export senv dir =
   (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
     (* error_export_simple *) (); *)
   let mb = 
-    { mod_expr = Some (MEBstruct (modinfo.msid, List.rev senv.revstruct));
-      mod_type = MTBsig (modinfo.msid, List.rev senv.revsign);
-      mod_user_type = None;
-      mod_equiv = None;
-      mod_constraints = senv.univ }
+    { mod_expr = Some (SEBstruct (modinfo.msid, List.rev senv.revstruct));
+      mod_type = None;
+      mod_constraints = senv.univ;
+      mod_alias = senv.modinfo.alias_subst;
+      mod_retroknowledge = senv.local_retroknowledge}
   in
     modinfo.msid, (dir,mb,senv.imports,engagement senv.env)
 
@@ -532,6 +745,8 @@ let check_imports senv needed =
   in
   List.iter check needed
 
+
+
 (* we have an inefficiency: Since loaded files are added to the
 environment every time a module is closed, their components are
 calculated many times. Thic could be avoided in several ways:
@@ -550,56 +765,46 @@ let import (dp,mb,depends,engmt) digest senv =
   check_engagement senv.env engmt;
   let mp = MPfile dp in
   let env = senv.env in
+  let env = Environ.add_constraints mb.mod_constraints env in
+  let env = Modops.add_module mp mb env in
   mp, { senv with 
-	  env = full_add_module mp mb env; 
+	  env = env; 
 	  imports = (dp,digest)::senv.imports;
 	  loads = (mp,mb)::senv.loads }
 
 
 (* Remove the body of opaque constants in modules *)
- 
-let rec lighten_module mb =
+ let rec lighten_module mb =
   { mb with
-    mod_expr = option_map lighten_modexpr mb.mod_expr;
-    mod_type = lighten_modtype mb.mod_type;
-    mod_user_type = option_map lighten_modtype mb.mod_user_type }
-
-and lighten_modtype = function
-  | MTBident kn as x -> x
-  | MTBfunsig (mbid,mtb1,mtb2) ->
-      MTBfunsig (mbid, lighten_modtype mtb1, lighten_modtype mtb2)
-  | MTBsig (msid,sign) -> MTBsig (msid, lighten_sig sign)
-
-and lighten_modspec ms =
-  { ms with msb_modtype = lighten_modtype ms.msb_modtype }
-
-and lighten_sig sign = 
-  let lighten_spec (l,spec) = (l,match spec with
-    | SPBconst ({const_opaque=true} as x) -> SPBconst {x with const_body=None}
-    | (SPBconst _ | SPBmind _) as x -> x
-    | SPBmodule m -> SPBmodule (lighten_modspec m)
-    | SPBmodtype m -> SPBmodtype (lighten_modtype m))
-  in
-    List.map lighten_spec sign
-
+    mod_expr = Option.map lighten_modexpr mb.mod_expr;
+    mod_type = Option.map lighten_modexpr mb.mod_type;
+  }
+    
 and lighten_struct struc = 
   let lighten_body (l,body) = (l,match body with
-    | SEBconst ({const_opaque=true} as x) -> SEBconst {x with const_body=None}
-    | (SEBconst _ | SEBmind _) as x -> x
-    | SEBmodule m -> SEBmodule (lighten_module m)
-    | SEBmodtype m -> SEBmodtype (lighten_modtype m))
+    | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
+    | (SFBconst _ | SFBmind _ | SFBalias _) 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
-  | MEBfunctor (mbid,mty,mexpr) ->
-      MEBfunctor (mbid,lighten_modtype mty,lighten_modexpr mexpr)
-  | MEBident mp as x -> x
-  | MEBstruct (msid, struc) ->
-      MEBstruct (msid, lighten_struct struc)
-  | MEBapply (mexpr,marg,u) ->
-      MEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
-
+  | SEBfunctor (mbid,mty,mexpr) ->
+      SEBfunctor (mbid, 
+		    ({mty with 
+			typ_expr = lighten_modexpr mty.typ_expr}),
+		  lighten_modexpr mexpr)
+  | SEBident mp as x -> x
+  | SEBstruct (msid, struc) ->
+      SEBstruct (msid, 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)
 
 
@@ -611,3 +816,6 @@ let j_type j = j.uj_type
 let safe_infer senv = infer (env_of_senv senv)
     
 let typing senv = Typeops.typing (env_of_senv senv)
+
+
+
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index c3d0abde..6d656f8b 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli 8723 2006-04-16 15:51:02Z herbelin $ i*)
+(*i $Id: safe_typing.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Names
@@ -57,10 +57,14 @@ val add_module :
   label -> module_entry -> safe_environment 
     -> module_path * safe_environment
 
+(* Adding a module alias*)
+val add_alias :
+  label -> module_path -> safe_environment 
+    -> module_path * safe_environment
 (* Adding a module type *)
 val add_modtype :
-  label -> module_type_entry -> safe_environment 
-    -> kernel_name * safe_environment
+  label -> module_struct_entry -> safe_environment 
+    -> module_path * safe_environment
 
 (* Adding universe constraints *)
 val add_constraints : 
@@ -73,20 +77,21 @@ val set_engagement : engagement -> safe_environment -> safe_environment
 (*s Interactive module functions *)
 val start_module : 
   label -> safe_environment -> module_path * safe_environment
-
 val end_module :
-  label -> module_type_entry option 
+  label -> module_struct_entry option 
       -> safe_environment -> module_path * safe_environment 
 
 val add_module_parameter :
-  mod_bound_id -> module_type_entry -> safe_environment -> safe_environment
+  mod_bound_id -> module_struct_entry -> safe_environment -> safe_environment
 
 val start_modtype :
   label -> safe_environment -> module_path * safe_environment
 
 val end_modtype :
-  label -> safe_environment -> kernel_name * safe_environment
+  label -> safe_environment -> module_path * safe_environment
 
+val add_include :
+  module_struct_entry -> safe_environment -> safe_environment
 
 val current_modpath : safe_environment -> module_path
 val current_msid : safe_environment -> mod_self_id
@@ -126,3 +131,12 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
 val typing : safe_environment -> constr -> judgment
 
 
+
+(*spiwack: safe retroknowledge functionalities *)
+
+open Retroknowledge
+
+val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a
+
+val register : safe_environment -> field -> Retroknowledge.entry -> constr
+                                         -> safe_environment
diff --git a/kernel/sign.ml b/kernel/sign.ml
index b42ca581..8fa59809 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml 9103 2006-09-01 11:02:52Z herbelin $ *)
+(* $Id: sign.ml 10451 2008-01-18 17:20:28Z barras $ *)
 
 open Names
 open Util
@@ -73,7 +73,7 @@ let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
 
 let map_context f l =
   let map_decl (n, body_o, typ as decl) =
-    let body_o' = option_smartmap f body_o in
+    let body_o' = Option.smartmap f body_o in
     let typ' = f typ in
       if body_o' == body_o && typ' == typ then decl else
 	(n, body_o', typ')
@@ -83,8 +83,8 @@ let map_context f l =
 let map_rel_context = map_context
 let map_named_context = map_context
 
-let iter_rel_context f = List.iter (fun (_,b,t) -> f t; option_iter f b)
-let iter_named_context f = List.iter (fun (_,b,t) -> f t; option_iter f b)
+let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
+let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
 
 (* Push named declarations on top of a rel context *)
 (* Bizarre. Should be avoided. *)
@@ -92,7 +92,7 @@ let push_named_to_rel_context hyps ctxt =
   let rec push = function
     | (id,b,t) :: l ->
 	let s, hyps = push l in
-	let d = (Name id, option_map (subst_vars s) b, type_app (subst_vars s) t) in
+	let d = (Name id, Option.map (subst_vars s) b, subst_vars s t) in
 	id::s, d::hyps
     | [] -> [],[] in
   let s, hyps = push hyps in
@@ -181,7 +181,9 @@ let decompose_prod_n_assum n =
   prodec_rec empty_rel_context n
 
 (* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
-   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+   into the pair ([(xn,Tn);...;(x1,T1)],T)
+   Lets in between are not expanded but turn into local definitions,
+   but n is the actual number of destructurated lambdas.  *)
 let decompose_lam_n_assum n =
   if n < 0 then
     error "decompose_lam_n_assum: integer parameter must be positive";
@@ -189,7 +191,7 @@ let decompose_lam_n_assum n =
     if n=0 then l,c 
     else match kind_of_term c with 
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
-    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
+    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c
     | Cast (c,_,_)      -> lamdec_rec l n c
     | c -> error "decompose_lam_n_assum: not enough abstractions"
   in 
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 2e6e5a34..14020c0b 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml 10031 2007-07-19 18:05:46Z soubiran $ i*)
+(*i $Id: subtyping.ml 11142 2008-06-18 15:37:31Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -22,16 +22,18 @@ 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 *)
-
 type namedobject = 
   | Constant of constant_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
-  | Module of module_specification_body
+  | Module of module_body
   | Modtype of module_type_body
+  | Alias of module_path
 
 (* adds above information about one mutual inductive: all types and
    constructors *)
@@ -57,11 +59,12 @@ let make_label_map mp list =
   let add_one (l,e) map = 
    let add_map obj = Labmap.add l obj map in
    match e with
-    | SPBconst cb -> add_map (Constant cb)
-    | SPBmind mib ->
+    | SFBconst cb -> add_map (Constant cb)
+    | SFBmind mib ->
        add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map
-    | SPBmodule mb -> add_map (Module mb)
-    | SPBmodtype mtb -> add_map (Modtype mtb)
+    | SFBmodule mb -> add_map (Module mb)
+    | SFBmodtype mtb -> add_map (Modtype mtb)
+    | SFBalias (mp,cst) -> add_map (Alias mp)
   in
     List.fold_right add_one list Labmap.empty
 
@@ -72,11 +75,9 @@ let check_conv_error error cst f env a1 a2 =
       NotConvertible -> error ()
 
 (* for now we do not allow reorderings *)
-let check_inductive cst env msid1 l info1 mib2 spec2 path1 path2 = 
+let check_inductive cst env msid1 l info1 mib2 spec2 = 
   let kn = make_kn (MPself msid1) empty_dirpath l in
-  let error () = error_not_match l
-    (String.concat "." (List.map string_of_id (List.rev path1)))
-    (String.concat "." (List.map string_of_id (List.rev path2))) in
+  let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
   let mib1 = 
     match info1 with
@@ -111,7 +112,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 path1 path2 =
     let (ctx2,s2) = dest_arity env t2 in
     let s1,s2 =
       match s1, s2 with
-      | Type _, Type _ -> (* shortcut here *) mk_Prop, mk_Prop
+      | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort
       | (Prop _, Type _) | (Type _,Prop _) -> error ()
       | _ -> (s1, s2) in
     check_conv cst conv_leq env 
@@ -194,10 +195,8 @@ let check_inductive cst env msid1 l info1 mib2 spec2 path1 path2 =
   in
     cst
     
-let check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 = 
-  let error () = error_not_match l
-    (String.concat "." (List.map string_of_id (List.rev path1)))
-    (String.concat "." (List.map string_of_id (List.rev path2))) in
+let check_constant cst env msid1 l info1 cb2 spec2 = 
+  let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
   let check_type cst env t1 t2 = 
 
@@ -223,13 +222,13 @@ let check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 =
             | Type u when not (is_univ_variable u) ->
               (* Both types are inferred, no need to recheck them. We
                  cheat and collapse the types to Prop *)
-                Sign.mkArity (ctx1,mk_Prop), Sign.mkArity (ctx2,mk_Prop)
+                Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort)
             | Prop _ ->
               (* The type in the interface is inferred, it may be the case
                  that the type in the implementation is smaller because
                  the body is more reduced. We safely collapse the upper
                  type to Prop *)
-                Sign.mkArity (ctx1,mk_Prop), Sign.mkArity (ctx2,mk_Prop)
+                Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort)
             | Type _ ->
               (* The type in the interface is inferred and the type in the
                  implementation is not inferred or is inferred but from a
@@ -255,55 +254,42 @@ let check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 =
       let cst = check_type cst env typ1 typ2 in
       let con = make_con (MPself msid1) empty_dirpath l in
       let cst =
-	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
-		begin
-		  match cb1.const_opaque,cb2.const_opaque with
-		      false,false |true,true ->
-			check_conv cst conv env c1 c2
-		    | false,true -> 
-			begin
-			  match kind_of_term c1 with
-			    | Const con' ->
-				let c1 = 
-				  match (Pre_env.lookup_constant con' 
-					   (pre_env env)).const_body with
-				      Some c -> Declarations.force c
-				    | None -> mkConst con'
-				in
-				  check_conv cst conv env c1 c2
-			    | _ ->
-				check_conv cst conv env c1 c2
-			end
-		    | true,false->
+	if cb2.const_opaque then
+	  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 c2) with
-			    | Const con'-> 
-				if con' = con 
-				then cst
-				else
-				let c2 = 
-				  match (Pre_env.lookup_constant con' 
-					   (pre_env env)).const_body with
-				      Some c -> Declarations.force c
-				    | None -> mkConst con'
-				in
-				  check_conv cst conv env c1 c2
-			    | _ ->
-				check_conv cst conv env c1 c2
+			  match (kind_of_term c) with
+			      Const n -> 
+				let cb = lookup_constant n env in
+				  (match cb.const_opaque,
+				     cb.const_body with
+				       | true, Some lc1 -> 
+					   Declarations.force lc1
+				       | _,_ -> c)
+			    | _ -> c
 			end
-		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
    | IndType ((kn,i),mind1) ->
-      ignore (Util.error (
+       ignore (Util.error (
        "The kernel does not recognize yet that a parameter can be " ^
        "instantiated by an inductive type. Hint: you can rename the " ^
        "inductive type and give a definition to map the old name to the new " ^
@@ -326,38 +312,28 @@ let check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 =
        check_conv cst conv env ty1 ty2
    | _ -> error ()
 	      
-let rec check_modules cst env msid1 l msb1 msb2 path1 path2 =
+let rec check_modules cst env msid1 l msb1 msb2 alias =
   let mp = (MPdot(MPself msid1,l)) in
-  let mty1 = strengthen env msb1.msb_modtype mp in
-  let cst = check_modtypes cst env mty1 msb2.msb_modtype false 
-    path1 path2 in
-    begin
-      match msb1.msb_equiv, msb2.msb_equiv with
-	| _, None -> ()
-	| None, Some mp2 -> 
-	    begin  
-	      try
-		check_modpath_equiv env mp mp2
-	      with Not_equiv_path -> error_not_equal mp mp2
-	    end
-	| Some mp1, Some mp2 -> try
-	    check_modpath_equiv env mp1 mp2
-	  with Not_equiv_path -> error_not_equal mp1 mp2
-    end;
+  let mty1 = module_type_of_module (Some mp) msb1 in
+  let alias1,struct_expr = match eval_struct env mty1.typ_expr with
+    	| SEBstruct (msid,sign) as str ->
+	    update_subst alias (map_msid msid mp),str
+	| _ as str -> empty_subst,str in
+  let mty1 = {mty1 with 
+		typ_expr = struct_expr;
+		typ_alias = join alias1 mty1.typ_alias } in
+  let mty2 =  module_type_of_module None msb2 in
+  let cst = check_modtypes cst env mty1 mty2 false in
     cst
 	
 
-and check_signatures cst env (msid1,sig1) (msid2,sig2') path1 path2= 
+and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = 
   let mp1 = MPself msid1 in
   let env = add_signature mp1 sig1 env in 
-  let sig2 = try
-    subst_signature_msid msid2 mp1 sig2' 
-    with
-    | Circularity l -> 
-	error_circularity_in_subtyping l
-	  (String.concat "." (List.map string_of_id (List.rev path1)))
-	  (String.concat "." (List.map string_of_id (List.rev path2)))
-  in
+  let sig1 = subst_structure alias sig1 in
+  let alias1 = update_subst alias (map_msid msid2 mp1) in
+  let sig2 = subst_structure alias1 sig2' in
+  let sig2 = subst_signature_msid msid2 mp1 sig2 in
   let map1 = make_label_map mp1 sig1 in
   let check_one_body cst (l,spec2) = 
     let info1 = 
@@ -365,72 +341,90 @@ and check_signatures cst env (msid1,sig1) (msid2,sig2') path1 path2=
 	Labmap.find l map1 
       with 
 	  Not_found -> error_no_such_label_sub l 
-	    (String.concat "." (List.map string_of_id (List.rev path1)))
-	    (String.concat "." (List.map string_of_id (List.rev path2)))
+	    (string_of_msid msid1) (string_of_msid msid2)
     in
       match spec2 with
-	| SPBconst cb2 ->
-	    check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2
-	| SPBmind mib2 -> 
-	    check_inductive cst env msid1 l info1 mib2 spec2 path1 path2
-	| SPBmodule msb2 -> 
-	    let msb1 = 
+	| SFBconst cb2 ->
+	    check_constant cst env msid1 l info1 cb2 spec2
+	| SFBmind mib2 -> 
+	    check_inductive cst env msid1 l info1 mib2 spec2
+	| SFBmodule msb2 ->  
+	    begin
 	      match info1 with
-		| Module msb -> msb
-		| _ -> error_not_match l 
-		    (String.concat "." (List.map string_of_id (List.rev path1)))
-		      (String.concat "." (List.map string_of_id (List.rev path2)))
-
-	    in
-	      check_modules cst env msid1 l msb1 msb2 path1 path2
-	| SPBmodtype mtb2 ->
+		| Module msb -> check_modules cst env msid1 l msb msb2 alias
+		| Alias mp ->let msb = 
+		    {mod_expr = Some (SEBident mp);
+		     mod_type = Some (eval_struct env (SEBident mp));
+		     mod_constraints = Constraint.empty;
+		     mod_alias = (lookup_modtype mp env).typ_alias;
+		     mod_retroknowledge = []} in
+		    check_modules cst env msid1 l msb msb2 alias
+		| _ -> error_not_match l spec2
+	    end
+	| SFBalias (mp,_) ->
+	    begin	
+	      match info1 with
+		| Alias mp1 -> check_modpath_equiv env mp mp1; cst
+		| Module msb -> 
+		    let msb1 = 
+		      {mod_expr = Some (SEBident mp);
+		       mod_type = Some (eval_struct env (SEBident mp));
+		       mod_constraints = Constraint.empty;
+		       mod_alias = (lookup_modtype mp env).typ_alias;
+		       mod_retroknowledge = []} in
+			check_modules cst env msid1 l msb msb1 alias
+		| _ -> error_not_match l spec2
+	    end
+	| SFBmodtype mtb2 ->
 	    let mtb1 = 
 	      match info1 with
 		| Modtype mtb -> mtb
-		| _ -> error_not_match l 
-		    (String.concat "." (List.map string_of_id (List.rev path1)))
-		      (String.concat "." (List.map string_of_id (List.rev path2)))
-
+		| _ -> error_not_match l spec2
 	    in
-	      check_modtypes cst env mtb1 mtb2 true path1 path2
+	      check_modtypes cst env mtb1 mtb2 true
   in
     List.fold_left check_one_body cst sig2
     
-and check_modtypes cst env mtb1 mtb2 equiv path1 path2 = 
+
+and check_modtypes cst env mtb1 mtb2 equiv = 
   if mtb1==mtb2 then cst else (* just in case  :) *)
-  let mtb1' = scrape_modtype env mtb1 in
-  let mtb2' = scrape_modtype env mtb2 in
-    if mtb1'==mtb2' then cst else
-    match mtb1', mtb2' with
-      | MTBsig (msid1,list1), 
-	MTBsig (msid2,list2) -> 
-	  let cst = check_signatures cst env (msid1,list1) (msid2,list2)
-	    ((id_of_msid msid1)::path1) ((id_of_msid msid2)::path2) in
-	  if equiv then
-	    check_signatures cst env (msid2,list2) (msid1,list1) 
-	      ((id_of_msid msid2)::path2) ((id_of_msid msid1)::path1)
-	  else
-	    cst
-      | MTBfunsig (arg_id1,arg_t1,body_t1), 
-	MTBfunsig (arg_id2,arg_t2,body_t2) ->
-	  let cst = check_modtypes cst env arg_t2 arg_t1 equiv 
-	  [] [] in 
-	    (* contravariant *)
-	  let env = 
-	    add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
-	  in
-	  let body_t1' = 
-            (* since we are just checking well-typedness we do not need
-               to expand any constant. Hence the identity resolver. *)
-	    subst_modtype 
-              (map_mbid arg_id1 (MPbound arg_id2) None)
-	      body_t1
-	  in
-	  check_modtypes cst env body_t1' body_t2 equiv
-	    path1 path2
-      | MTBident _ , _ -> anomaly "Subtyping: scrape failed"
-      | _ , MTBident _ -> anomaly "Subtyping: scrape failed"
-      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+  let mtb1',mtb2'=
+    (match mtb1.typ_strength with
+	 None -> eval_struct env mtb1.typ_expr,
+	   eval_struct env mtb2.typ_expr
+       | Some mp -> strengthen  env mtb1.typ_expr mp,
+	   eval_struct env mtb2.typ_expr) in
+      let rec check_structure cst env str1 str2 equiv = 
+	match str1, str2 with
+	  | SEBstruct (msid1,list1), 
+	    SEBstruct (msid2,list2) -> 
+	      let cst = check_signatures cst env
+		(msid1,list1) mtb1.typ_alias (msid2,list2) in
+		if equiv then
+		  check_signatures cst env 
+		    (msid2,list2) mtb2.typ_alias  (msid1,list1) 
+		else
+		  cst
+	  | SEBfunctor (arg_id1,arg_t1,body_t1), 
+	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
+	      let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
+		(* contravariant *)
+	      let env = 
+		add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	      in
+	      let body_t1' = 
+		(* since we are just checking well-typedness we do not need
+		   to expand any constant. Hence the identity resolver. *)
+		subst_struct_expr
+		  (map_mbid arg_id1 (MPbound arg_id2) None)
+		  body_t1
+	      in
+		check_structure cst env (eval_struct env body_t1')
+		  (eval_struct env body_t2) equiv
+	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+      in 
+     if mtb1'== mtb2' then cst 
+     else check_structure cst env mtb1' mtb2' equiv
 	  
 let check_subtypes env sup super = 
-  check_modtypes Constraint.empty env sup super false [] []
+  check_modtypes Constraint.empty env sup super false
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index 8bc25464..0445666d 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: subtyping.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
 
 (*i*)
 open Univ
diff --git a/kernel/term.ml b/kernel/term.ml
index 456a29e4..c920c80b 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml 9303 2006-10-27 21:50:17Z herbelin $ *)
+(* $Id: term.ml 10859 2008-04-27 16:46:15Z herbelin $ *)
 
 (* This module instantiates the structure of generic deBruijn terms to Coq *)
 
@@ -24,12 +24,10 @@ type metavariable = int
 (* This defines the strategy to use for verifiying a Cast *)
 
 (* This defines Cases annotations *)
-type pattern_source = DefaultPat of int | RegularPat
-type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 type case_printing =
   { ind_nargs : int; (* number of real args of the inductive type *)
-    style     : case_style;
-    source    : pattern_source array }
+    style     : case_style }
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
@@ -45,8 +43,9 @@ type sorts =
   | Prop of contents                      (* proposition types *)
   | Type of universe
       
-let mk_Set  = Prop Pos
-let mk_Prop = Prop Null
+let prop_sort = Prop Null
+let set_sort = Prop Pos
+let type1_sort = Type type1_univ
 
 type sorts_family = InProp | InSet | InType
 
@@ -390,7 +389,9 @@ let destApplication = destApp
 
 let isApp c = match kind_of_term c with App _ -> true | _ -> false
 
-let isProd c = match kind_of_term c with | Prod(_) -> true | _ -> false
+let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false
+
+let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 
 (* Destructs a constant *)
 let destConst c = match kind_of_term c with
@@ -636,17 +637,13 @@ type types = constr
 
 type strategy = types option 
 
-let type_app f tt = f tt
-
-let body_of_type ty = ty
-
 type named_declaration = identifier * constr option * types
 type rel_declaration = name * constr option * types
 
-let map_named_declaration f (id, v, ty) = (id, option_map f v, f ty)
+let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty)
 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_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
 let fold_rel_declaration = fold_named_declaration
 
 (****************************************************************************)
@@ -777,7 +774,7 @@ 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)
+  (id,Option.map (substnl laml k) bodyopt,substnl laml k typ)
 let substl_decl laml = substnl_decl laml 0
 let subst1_decl lam = substl_decl [lam]
 let subst1_named_decl = subst1_decl
@@ -834,18 +831,14 @@ let mkMeta = mkMeta
 let mkVar = mkVar
 
 (* Construct a type *)
-let mkProp   = mkSort mk_Prop
-let mkSet    = mkSort mk_Set
+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
 
-let prop = mk_Prop
-and spec = mk_Set
-and type_0 = Type prop_univ
-
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
 (* (that means t2 is declared as the type of t1) *)
 let mkCast = mkCast
@@ -1181,6 +1174,3 @@ let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
 (*******)
 (* Type of abstract machine values *)
 type values
-
-
-
diff --git a/kernel/term.mli b/kernel/term.mli
index d6244f5b..6236dc39 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli 9303 2006-10-27 21:50:17Z herbelin $ i*)
+(*i $Id: term.mli 10859 2008-04-27 16:46:15Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,9 +21,9 @@ type sorts =
   | Prop of contents       (* Prop and Set *)
   | Type of Univ.universe  (* Type *)
 
-val mk_Set  : sorts
-val mk_Prop : sorts
-val type_0  : sorts
+val set_sort  : sorts
+val prop_sort : sorts
+val type1_sort  : sorts
 
 (*s The sorts family of CCI. *)
 
@@ -40,12 +40,10 @@ type existential_key = int
 type metavariable = int
 
 (*s Case annotation *)
-type pattern_source = DefaultPat of int | RegularPat
-type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 type case_printing =
   { ind_nargs : int; (* number of real args of the inductive type *)
-    style     : case_style;
-    source    : pattern_source array }
+    style     : case_style }
 (* the integer is the number of real args, needed for reduction *)
 type case_info =
   { ci_ind        : inductive;
@@ -63,18 +61,13 @@ type constr
    and application grouping *)
 val eq_constr : constr -> constr -> bool
 
-(* [types] is the same as [constr] but is intended to be used where a
-   {\em type} in CCI sense is expected (Rem:plurial form since [type] is a
-   reserved ML keyword) *)
+(* [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). 
+   (Rem:plurial form since [type] is a reserved ML keyword) *)
 
 type types = constr
 
-(*s Functions about [types] *)
-
-val type_app : (constr -> constr) -> types -> types
-
-val body_of_type : types -> constr
-
 (*s Functions for dealing with constr terms.
   The following functions are intended to simplify and to uniform the 
   manipulation of terms. Some of these functions may be overlapped with
@@ -236,6 +229,7 @@ val isMeta : constr -> bool
 val isSort : constr -> bool
 val isCast : constr -> bool
 val isApp : constr -> bool
+val isLambda : constr -> bool
 val isProd : constr -> bool
 val isConst : constr -> bool
 val isConstruct : constr -> bool
@@ -445,8 +439,8 @@ val noccurn : int -> constr -> bool
 val noccur_between : int -> int -> constr -> bool
 
 (* Checking function for terms containing existential- or
-   meta-variables.  The function [noccur_with_meta] considers only
-   meta-variable applied to some terms (intented to be its local
+   meta-variables.  The function [noccur_with_meta] does not consider
+   meta-variables applied to some terms (intented to be its local
    context) (for existential variables, it is necessarily the case) *)
 val noccur_with_meta : int -> int -> constr -> bool
 
@@ -455,7 +449,7 @@ val noccur_with_meta : int -> int -> constr -> bool
 (* [exliftn el c] lifts [c] with lifting [el] *)
 val exliftn : Esubst.lift -> constr -> constr
 
-(* [liftn n k c] lifts by [n] indexes above [k] in [c] *)
+(* [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] *)
@@ -479,10 +473,10 @@ val replace_vars : (identifier * constr) list -> constr -> constr
 val subst_var : identifier -> constr -> constr
 
 (* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
-   if two names are identical, the one of least indice is keeped *)
+   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]
-   if two names are identical, the one of least indice is keeped *)
+   if two names are identical, the one of least indice is kept *)
 val substn_vars : int -> identifier list -> constr -> constr
 
 
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 575330a4..0f649057 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term_typing.ml 9323 2006-10-30 23:05:29Z herbelin $ *)
+(* $Id: term_typing.ml 10877 2008-04-30 21:58:41Z herbelin $ *)
 
 open Util
 open Names
@@ -24,10 +24,7 @@ open Typeops
 
 let constrain_type env j cst1 = function
   | None ->
-(* To have definitions in Type polymorphic
-      make_polymorphic_if_arity env j.uj_type, cst1
-*) 
-      NonPolymorphicType j.uj_type, cst1
+      make_polymorphic_if_constant_for_ind env j, cst1
   | Some t -> 
       let (tj,cst2) = infer_type env t in
       let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
@@ -93,11 +90,11 @@ let infer_declaration env dcl =
       let (j,cst) = infer env c.const_entry_body in
       let (typ,cst) = constrain_type env j cst c.const_entry_type in
       Some (Declarations.from_val j.uj_val), typ, cst,
-        c.const_entry_opaque, c.const_entry_boxed
-  | ParameterEntry t ->
+        c.const_entry_opaque, c.const_entry_boxed, false
+  | ParameterEntry (t,nl) ->
       let (j,cst) = infer env t in
       None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst,
-        false, false
+        false, false, nl
 
 let global_vars_set_constant_type env = function
   | NonPolymorphicType t -> global_vars_set env t
@@ -107,7 +104,7 @@ 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) =
+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
@@ -124,7 +121,8 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed) =
       const_body_code = tps;
      (* const_type_code = to_patch env typ;*)
       const_constraints = cst;
-      const_opaque = op }
+      const_opaque = op; 
+      const_inline = inline}
 
 (*s Global and local constant declaration. *)
 
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index c102d01b..d84cfe91 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term_typing.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: term_typing.mli 9795 2007-04-25 15:13:45Z soubiran $ i*)
 
 (*i*)
 open Names
@@ -26,10 +26,10 @@ val translate_local_assum : env -> types ->
   types * Univ.constraints
 
 val infer_declaration : env -> constant_entry -> 
-   constr_substituted option * constant_type * constraints * bool * bool
+   constr_substituted option * constant_type * constraints * bool * bool * bool
 
 val build_constant_declaration : env -> 'a ->
-    constr_substituted option * constant_type * constraints * bool * bool ->
+    constr_substituted option * constant_type * constraints * bool * bool * bool ->
       constant_body
 
 val translate_constant : env -> constant -> constant_entry -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 87de6698..1a49531b 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml 8845 2006-05-23 07:41:58Z herbelin $ *)
+(* $Id: type_errors.ml 10533 2008-02-08 16:54:47Z msozeau $ *)
 
 open Names
 open Term
@@ -56,7 +56,7 @@ type type_error =
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int
+  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
   | IllTypedRecBody of
       int * name array * unsafe_judgment array * types array
 
@@ -105,8 +105,8 @@ let error_cant_apply_not_functional env rator randl =
 let error_cant_apply_bad_type env t rator randl =
   raise (TypeError (env, CantApplyBadType (t,rator,randl)))
 
-let error_ill_formed_rec_body env why lna i =
-  raise (TypeError (env, IllFormedRecBody (why,lna,i)))
+let error_ill_formed_rec_body env why lna i fixenv vdefj =
+  raise (TypeError (env, IllFormedRecBody (why,lna,i,fixenv,vdefj)))
 
 let error_ill_typed_rec_body env i lna vdefj vargs =
   raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 138c313c..368e1723 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli 8845 2006-05-23 07:41:58Z herbelin $ i*)
+(*i $Id: type_errors.mli 10533 2008-02-08 16:54:47Z msozeau $ i*)
 
 (*i*)
 open Names
@@ -58,7 +58,7 @@ type type_error =
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int
+  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
   | IllTypedRecBody of
       int * name array * unsafe_judgment array * types array
 
@@ -96,7 +96,7 @@ val error_cant_apply_bad_type :
       unsafe_judgment -> unsafe_judgment array -> 'a
 
 val error_ill_formed_rec_body :
-  env -> guard_error -> name array -> int -> 'a
+  env -> guard_error -> name array -> int -> env -> unsafe_judgment array -> 'a
 
 val error_ill_typed_rec_body  :
   env -> int -> name array -> unsafe_judgment array -> types array -> 'a
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 2a0dd526..e548e6f5 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
+(* $Id: typeops.ml 10877 2008-04-30 21:58:41Z herbelin $ *)
 
 open Util
 open Names
@@ -59,11 +59,11 @@ let sort_judgment env j = (type_judgment env j).utj_type
 
 let judge_of_prop =
   { uj_val = mkProp;
-    uj_type = mkSort type_0 }
+    uj_type = mkSort type1_sort }
 
 let judge_of_set =
   { uj_val = mkSet;
-    uj_type = mkSort type_0 }
+    uj_type = mkSort type1_sort }
 
 let judge_of_prop_contents = function
   | Null -> judge_of_prop
@@ -82,7 +82,7 @@ let judge_of_relative env n =
   try
     let (_,_,typ) = lookup_rel n env in
     { uj_val  = mkRel n;
-      uj_type = type_app (lift n) typ }
+      uj_type = lift n typ }
   with Not_found -> 
     error_unbound_rel env n
 
@@ -135,10 +135,10 @@ let extract_context_levels env =
   List.fold_left
     (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
 
-let make_polymorphic_if_arity env t =
+let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} =
   let params, ccl = dest_prod_assum env t in
   match kind_of_term ccl with
-  | Sort (Type u) -> 
+  | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) ->
       let param_ccls = extract_context_levels env params in
       let s = { poly_param_levels = param_ccls; poly_level = u} in
       PolymorphicArity (params,s)
@@ -192,7 +192,7 @@ let judge_of_abstraction env name var j =
 
 let judge_of_letin env name defj typj j =
   { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ;
-    uj_type = type_app (subst1 defj.uj_val) j.uj_type }
+    uj_type = subst1 defj.uj_val j.uj_type }
 
 (* Type of an application. *)
 
@@ -237,9 +237,9 @@ let sort_of_product env domsort rangsort =
           rangsort
         else
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          Type (sup u1 base_univ)
+          Type (sup u1 type0_univ)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Pos,  Type u2)  -> Type (sup base_univ u2)
+    | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
     (* Product rule (Prop,Type_i,Type_i) *)
     | (Prop Null, Type _)  -> rangsort
     (* Product rule (Type_i,Type_i,Type_i) *) 
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 1e73725f..c427055a 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*)
+(*i $Id: typeops.mli 10877 2008-04-30 21:58:41Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -105,5 +105,6 @@ val type_of_constant_knowing_parameters :
   env -> constant_type -> constr array -> types
 
 (* Make a type polymorphic if an arity *)
-val make_polymorphic_if_arity : env -> types -> constant_type
+val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
+  constant_type
 
diff --git a/kernel/univ.ml b/kernel/univ.ml
index df06e9af..3791c3e1 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml 9507 2007-01-20 08:09:54Z herbelin $ *)
+(* $Id: univ.ml 11063 2008-06-06 16:03:45Z soubiran $ *)
 
 (* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
 (* Extension with algebraic universes by HH [Sep 2001] *)
@@ -40,7 +40,7 @@ open Util
  *)
 
 type universe_level =
-  | Base
+  | Set
   | Level of Names.dir_path * int
 
 type universe =
@@ -53,7 +53,7 @@ module UniverseOrdered = struct
 end
 
 let string_of_univ_level = function
-  | Base -> "0"
+  | Set -> "0"
   | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
 
 let make_univ (m,n) = Atom (Level (m,n))
@@ -79,7 +79,7 @@ let super = function
   | Atom u -> 
       Max ([],[u])
   | Max _ ->
-      anomaly ("Cannot take the successor of a non variable universes:\n"^
+      anomaly ("Cannot take the successor of a non variable universe:\n"^
                "(maybe a bugged tactic)")
 
 (* Returns the formal universe that is greater than the universes u and v.
@@ -96,8 +96,6 @@ let sup u v =
 	let gtl'' = list_union gtl gtl' in
 	Max (list_subtract gel'' gtl'',gtl'')
 
-let neutral_univ = Max ([],[])
-
 (* Comparison on this type is pointer equality *)
 type canonical_arc =
     { univ: universe_level; lt: universe_level list; le: universe_level list }
@@ -126,23 +124,32 @@ let declare_univ u g =
   else
     g
 
-(* The level of Set *)
-let base_univ = Atom Base
+(* The lower predicative level of the hierarchy that contains (impredicative)
+   Prop and singleton inductive types *)
+let type0m_univ = Max ([],[])
+
+let is_type0m_univ = function
+  | Max ([],[]) -> true
+  | _ -> false
+
+(* The level of predicative Set *)
+let type0_univ = Atom Set
 
-let is_base_univ = function
-  | Atom Base -> true
-  | Max ([Base],[]) -> warning "Non canonical Set"; true
+let is_type0_univ = function
+  | Atom Set -> true
+  | Max ([Set],[]) -> warning "Non canonical Set"; true
   | u -> false
 
 let is_univ_variable = function
-  | Atom a when a<>Base -> true
+  | Atom a when a<>Set -> true
   | _ -> false
 
 (* When typing [Prop] and [Set], there is no constraint on the level,
-   hence the definition of [prop_univ], the type of [Prop] *)
+   hence the definition of [type1_univ], the type of [Prop] *)
+
+let type1_univ = Max ([],[Set])
 
 let initial_universes = UniverseMap.empty
-let prop_univ = Max ([],[Base])
 
 (* Every universe_level has a unique canonical arc representative *)
 
@@ -259,6 +266,55 @@ 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
+
+
+type check_function = universes -> universe -> universe -> bool
+
+let incl_list cmp l1 l2 =
+  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 
+
+let compare_list cmp l1 l2 =
+  incl_list cmp l1 l2 && incl_list cmp l2 l1
+
+let rec check_eq g u v =
+  match (u,v) with
+    | Atom ul, Atom vl -> compare_eq g ul vl
+    | Max(ule,ult), Max(vle,vlt) ->
+        (* TODO: remove elements of lt in le! *)
+        compare_list (compare_eq g) ule vle &&
+        compare_list (compare_eq g) ult vlt
+    | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
+
+let check_eq g u v =
+  check_eq g u v
+
+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
+    | (EQ|LE) -> not strict
+    | LT -> true
+    | NLE -> false
+(*
+let compare_greater g strict u v =
+  let b = compare_greater g strict u v in
+  ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
+  b
+*)
+let rec check_greater g strict u v =
+  match u, v with
+    | Atom ul, Atom vl -> compare_greater g strict 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 true ul vl) lt
+    | _ -> anomaly "check_greater"
+
+let check_geq g = check_greater g false
 
 (* setlt : universe_level -> universe_level -> unit *)
 (* forces u > v *)
@@ -314,9 +370,11 @@ let merge_disc g u v =
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-exception UniverseInconsistency
+type order_request = Lt | Le | Eq
 
-let error_inconsistency () = raise UniverseInconsistency
+exception UniverseInconsistency of order_request * 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 u v will force u<=v if possible, will fail otherwise *)
@@ -326,7 +384,7 @@ let enforce_univ_leq u v g =
   match compare g u v with
     | NLE -> 
 	(match compare g v u with
-           | LT -> error_inconsistency()
+           | LT -> error_inconsistency Le u v
            | LE -> merge g v u
            | NLE -> setleq g u v
            | EQ -> anomaly "Univ.compare")
@@ -339,11 +397,11 @@ let enforce_univ_eq u v g =
   let g = declare_univ v g in
   match compare g u v with
     | EQ -> g
-    | LT -> error_inconsistency()
+    | LT -> error_inconsistency Eq u v
     | LE -> merge g u v
     | NLE -> 
 	(match compare g v u with
-           | LT -> error_inconsistency()
+           | LT -> error_inconsistency Eq u v
            | LE -> merge g v u
            | NLE -> merge_disc g u v
            | EQ -> anomaly "Univ.compare")
@@ -355,11 +413,11 @@ let enforce_univ_lt u v g =
   match compare g u v with
     | LT -> g
     | LE -> setlt g u v
-    | EQ -> error_inconsistency()
+    | EQ -> error_inconsistency Lt u v
     | NLE -> 
 	(match compare g v u with
            | NLE -> setlt g u v
-           | _ -> error_inconsistency())
+           | _ -> error_inconsistency Lt u v)
 
 (*
 let enforce_univ_relation g = function 
@@ -401,7 +459,7 @@ type constraint_function =
     universe -> universe -> constraints -> constraints
 
 let constraint_add_leq v u c =
-  if v = Base then c else Constraint.add (v,Leq,u) c
+  if v = Set then c else Constraint.add (v,Leq,u) c
 
 let enforce_geq u v c =
   match u, v with
@@ -440,10 +498,6 @@ let remove_large_constraint u = function
   | Atom u' as x -> if u = u' then Max ([],[]) else x
   | Max (le,lt) -> make_max (list_remove u le,lt)
 
-let is_empty_univ = function
-  | Max ([],[]) -> true
-  | _ -> false
-
 let is_direct_constraint u = function
   | Atom u' -> u = u'
   | Max (le,lt) -> List.mem u le
@@ -468,7 +522,7 @@ let is_direct_sort_constraint s v = match s with
 
 let solve_constraints_system levels level_bounds =
   let levels = 
-    Array.map (option_map (function Atom u -> u | _ -> anomaly "expects Atom"))
+    Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom"))
       levels in
   let v = Array.copy level_bounds in
   let nind = Array.length v in
@@ -525,7 +579,15 @@ let pr_universes g =
   let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in
   prlist (function (_,a) -> pr_arc a) graph
     
-
+let pr_constraints c =
+  Constraint.fold (fun (u1,op,u2) pp_std -> 
+		     let op_str = match op with 
+		       | Lt -> " < "
+		       | Leq -> " <= "
+		       | Eq -> " = "
+		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
+			  pr_uni_level u2 ++ fnl () )  c (str "")
+    
 (* Dumping constrains to a file *)
 
 let dump_universes output g = 
@@ -556,7 +618,7 @@ module Huniv =
       type t = universe
       type u = Names.dir_path -> Names.dir_path
       let hash_aux hdir = function
-	| Base -> Base
+	| Set -> Set
 	| Level (d,n) -> Level (hdir d,n)
       let hash_sub hdir = function
 	| Atom u -> Atom (hash_aux hdir u)
@@ -575,3 +637,4 @@ module Huniv =
 let hcons1_univ u =
   let _,_,hdir,_,_,_ = Names.hcons_names() in
   Hashcons.simple_hcons Huniv.f hdir u
+
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 5f562a1d..0a1a8328 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -6,18 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli 9507 2007-01-20 08:09:54Z herbelin $ i*)
+(*i $Id: univ.mli 11063 2008-06-06 16:03:45Z soubiran $ i*)
 
 (* Universes. *)
 
 type universe
 
-val base_univ : universe
-val prop_univ : universe
-val neutral_univ : 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 *)
+
+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_univ : Names.dir_path * int -> universe
 
-val is_base_univ : universe -> bool
+val is_type0_univ : universe -> bool
+val is_type0m_univ : universe -> bool
 val is_univ_variable : universe -> bool
 
 (* The type of a universe *)
@@ -30,6 +35,10 @@ val sup   : universe -> universe -> universe
 
 type universes
 
+type check_function = universes -> universe -> universe -> bool
+val check_geq : check_function
+val check_eq : check_function
+
 (* The empty graph of universes *)
 val initial_universes : universes
 
@@ -49,7 +58,9 @@ val enforce_eq : constraint_function
   universes graph. It raises the exception [UniverseInconsistency] if the
   constraints are not satisfiable. *)
 
-exception UniverseInconsistency
+type order_request = Lt | Le | Eq
+
+exception UniverseInconsistency of order_request * universe * universe
 
 val merge_constraints : constraints -> universes -> universes
 
@@ -60,8 +71,6 @@ val fresh_local_univ : unit -> universe
 val solve_constraints_system : universe option array -> universe array -> 
   universe array
 
-val is_empty_univ : universe -> bool
-
 val subst_large_constraint : universe -> universe -> universe -> universe
 
 val subst_large_constraints : 
@@ -71,6 +80,7 @@ val subst_large_constraints :
 
 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 *)
 
diff --git a/kernel/vm.ml b/kernel/vm.ml
index c1d3ca56..4ed0592d 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: vm.ml 10739 2008-04-01 14:45:20Z herbelin $ *)
+
 open Names
 open Term
 open Conv_oracle