Imported Upstream version 8.0pl3+8.1alphaupstream/8.0pl3+8.1alpha

69 files changed, 6643 insertions, 1231 deletions

diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
new file mode 100644
index 00000000..4616580d
--- /dev/null
+++ b/kernel/byterun/coq_fix_code.c
@@ -0,0 +1,166 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h> 
+#include "config.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "fail.h"
+#include "memory.h"
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+
+#ifdef THREADED_CODE
+char ** coq_instr_table;
+char * coq_instr_base;
+int arity[STOP+1];
+
+void init_arity () {
+  /* instruction with zero operand */
+  arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]=
+    arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]=
+    arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]=arity[PUSHACC6]=
+    arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]=arity[ENVACC4]=
+    arity[PUSHENVACC1]=arity[PUSHENVACC2]=arity[PUSHENVACC3]=arity[PUSHENVACC4]=
+    arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]=
+    arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]=
+    arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]=
+    arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]=
+    arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]=
+    arity[ACCUMULATE]=arity[STOP]=arity[FORCE]=arity[MAKEPROD]= 0;
+  /* instruction with one operand */
+  arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]=
+    arity[PUSH_RETADDR]=
+    arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=arity[APPTERM3]=arity[RETURN]=
+    arity[GRAB]=arity[COGRAB]=
+    arity[OFFSETCLOSURE]=arity[PUSHOFFSETCLOSURE]=
+    arity[GETGLOBAL]=arity[PUSHGETGLOBAL]=
+    arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEACCU]=
+    arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=arity[PUSHFIELD]=
+    arity[ACCUMULATECOND]= 1;
+  /* instruction with two operands */
+  arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=2;
+  /* instruction with four operands */ 
+  arity[MAKESWITCHBLOCK]=4;
+  /* instruction with arbitrary operands */
+  arity[CLOSUREREC]=arity[SWITCH]=0;
+}
+
+#endif /*  THREADED_CODE */
+
+
+void * coq_stat_alloc (asize_t sz)
+{
+  void * result = malloc (sz);
+  if (result == NULL) raise_out_of_memory ();
+  return result;
+}
+
+value coq_makeaccu (value i) {
+  code_t q;
+  code_t res = coq_stat_alloc(8);
+  q = res;
+  *q++ = VALINSTR(MAKEACCU);
+  *q = (opcode_t)Int_val(i);
+  return (value)res;
+}
+
+value coq_accucond (value i) {
+  code_t q;
+  code_t res = coq_stat_alloc(8);
+  q = res;
+  *q++ = VALINSTR(ACCUMULATECOND);
+  *q = (opcode_t)Int_val(i);
+  return (value)res;
+}
+
+value coq_pushpop (value i) {
+  code_t res;
+  int n;
+  n = Int_val(i);
+  if (n == 0) {
+    res = coq_stat_alloc(4);
+    *res = VALINSTR(STOP);
+    return (value)res;
+  }
+  else {
+    code_t q;
+    res = coq_stat_alloc(12);
+    q = res;
+    *q++ = VALINSTR(POP);
+    *q++ = (opcode_t)n;
+    *q = VALINSTR(STOP);
+    return (value)res;
+  }
+}
+
+value coq_is_accumulate_code(value code){
+  code_t q;
+  int res;
+  q = (code_t)code;
+  res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE);
+  return Val_bool(res);
+}
+
+#ifdef ARCH_BIG_ENDIAN
+#define Reverse_32(dst,src) {                                               \
+  char * _p, * _q;							    \
+  char _a, _b;                                                              \
+  _p = (char *) (src);                                                      \
+  _q = (char *) (dst);                                                      \
+  _a = _p[0];                                                               \
+  _b = _p[1];                                                               \
+  _q[0] = _p[3];                                                            \
+  _q[1] = _p[2];                                                            \
+  _q[3] = _a;                                                               \
+  _q[2] = _b;                                                               \
+}
+#define COPY32(dst,src) Reverse_32(dst,src)
+#else
+#define COPY32(dst,src) (*dst=*src)
+#endif /* ARCH_BIG_ENDIAN */
+
+value coq_tcode_of_code (value code, value size) {
+  code_t p, q, res; 
+  asize_t len = (asize_t) Long_val(size);
+  res = coq_stat_alloc(len);
+  q = res;
+  len /= sizeof(opcode_t);
+  for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) {  
+    opcode_t instr;
+    COPY32(&instr,p); 
+    p++;
+    if (instr < 0 || instr > STOP){
+      instr = STOP;
+    };
+    *q++ = VALINSTR(instr);
+    if (instr == SWITCH) {
+      uint32 i, sizes, const_size, block_size;
+      COPY32(q,p); p++;
+      sizes=*q++;
+      const_size = sizes & 0xFFFF;
+      block_size = sizes >> 16;
+      sizes = const_size + block_size;
+      for(i=0; i<sizes; i++) { COPY32(q,p); p++; q++; };
+    } else if (instr == CLOSUREREC) {
+      uint32 i, n;
+      COPY32(q,p); p++; /* ndefs */
+      n = 3 + 2*(*q);  /* ndefs, nvars, start, typlbls,lbls*/
+      q++;
+      for(i=1; i<n; i++) { COPY32(q,p); p++; q++; };
+    } else {
+      uint32 i, ar;
+      ar = arity[instr]; 
+      for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; };
+    }
+  }
+  return (value)res;
+}
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
new file mode 100644
index 00000000..035d5b9b
--- /dev/null
+++ b/kernel/byterun/coq_fix_code.h
@@ -0,0 +1,34 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+
+#ifndef _COQ_FIX_CODE_
+#define _COQ_FIX_CODE_
+
+#include "mlvalues.h"
+void * coq_stat_alloc (asize_t sz);
+
+#ifdef THREADED_CODE
+extern char ** coq_instr_table;
+extern char * coq_instr_base;
+void init_arity();
+#define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base))
+#else
+#define VALINSTR(instr) instr
+#endif /*  THREADED_CODE */
+
+#define Is_instruction(pc,instr) (*pc == VALINSTR(instr))
+
+value coq_tcode_of_code(value code, value len);
+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_gc.h b/kernel/byterun/coq_gc.h
new file mode 100644
index 00000000..2f085326
--- /dev/null
+++ b/kernel/byterun/coq_gc.h
@@ -0,0 +1,48 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_CAML_GC_
+#define _COQ_CAML_GC_
+#include "mlvalues.h"
+#include "alloc.h"
+
+typedef void (*scanning_action) (value, value *);
+
+
+CAMLextern char *young_ptr;
+CAMLextern char *young_limit;
+CAMLextern void (*scan_roots_hook) (scanning_action);
+CAMLextern void minor_collection (void);
+
+#define Caml_white (0 << 8)
+#define Caml_black (3 << 8)
+
+#define Make_header(wosize, tag, color)                                 \
+  (((header_t) (((header_t) (wosize) << 10)                             \
+		+ (color)                                               \
+		+ (tag_t) (tag)))   					\
+   )
+
+
+#define Alloc_small(result, wosize, tag) do{                            \
+  young_ptr -= Bhsize_wosize (wosize);                                  \
+  if (young_ptr < young_limit){                                         \
+    young_ptr += Bhsize_wosize (wosize);                                \
+    Setup_for_gc;                                                       \
+    minor_collection ();                                                \
+    Restore_after_gc;                                                   \
+    young_ptr -= Bhsize_wosize (wosize);                                \
+  }                                                                     \
+  Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black);        \
+  (result) = Val_hp (young_ptr);                                        \
+  }while(0) 
+
+
+#endif /*_COQ_CAML_GC_ */
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
new file mode 100644
index 00000000..d3b07526
--- /dev/null
+++ b/kernel/byterun/coq_instruct.h
@@ -0,0 +1,39 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_INSTRUCT_
+#define _COQ_INSTRUCT_
+
+enum instructions {
+  ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC,
+  PUSH, 
+  PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4,
+  PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, 
+  POP,
+  ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC,
+  PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC,
+  PUSH_RETADDR,
+  APPLY, APPLY1, APPLY2, APPLY3,
+  APPTERM, APPTERM1, APPTERM2, APPTERM3,
+  RETURN, RESTART, GRAB, GRABREC, COGRAB, 
+  CLOSURE, CLOSUREREC, 
+  OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE,
+  PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, 
+  PUSHOFFSETCLOSURE,
+  GETGLOBAL, PUSHGETGLOBAL,
+  MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, 
+  MAKESWITCHBLOCK, MAKEACCU, MAKEPROD,
+  FORCE, SWITCH, PUSHFIELD,
+  CONST0, CONST1, CONST2, CONST3, CONSTINT,
+  PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
+  ACCUMULATE, ACCUMULATECOND, STOP
+};
+
+#endif /* _COQ_INSTRUCT_ */
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
new file mode 100644
index 00000000..8bfe78eb
--- /dev/null
+++ b/kernel/byterun/coq_interp.c
@@ -0,0 +1,974 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+/* The bytecode interpreter */
+
+#include <stdio.h>
+#include "coq_gc.h"
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+#include "coq_memory.h"  
+#include "coq_values.h"
+
+
+/* Registers for the abstract machine:
+        pc         the code pointer
+        sp         the stack pointer (grows downward)
+        accu       the accumulator
+        env        heap-allocated environment
+        trapsp     pointer to the current trap frame
+        extra_args number of extra arguments provided by the caller
+
+sp is a local copy of the global variable extern_sp. */
+
+
+
+/* Instruction decoding */
+
+
+#ifdef THREADED_CODE
+#  define Instruct(name) coq_lbl_##name: 
+#  if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#    define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0)
+#  else
+#    define coq_Jumptbl_base ((char *) 0)
+#    define coq_jumptbl_base ((char *) 0)
+#  endif
+#  ifdef DEBUG
+#    define Next goto next_instr
+#  else
+#    ifdef __ia64__
+#      define Next goto *(void *)(coq_jumptbl_base + *((uint32 *) pc)++)
+#    else
+#      define Next goto *(void *)(coq_jumptbl_base + *pc++)
+#    endif
+#  endif
+#else 
+#  define Instruct(name) case name:
+#  define Next break
+#endif 
+
+/* #define _COQ_DEBUG_ */
+
+#ifdef _COQ_DEBUG_ 
+#   define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s)
+#   define print_int(i)   /*if (drawinstr)*/ printf("%d\n",i)
+# else 
+#   define print_instr(s) 
+#   define print_int(i) 
+#endif
+
+/* GC interface */
+#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
+#define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
+
+
+/* Register optimization.
+   Some compilers underestimate the use of the local variables representing
+   the abstract machine registers, and don't put them in hardware registers,
+   which slows down the interpreter considerably.
+   For GCC, Xavier Leroy have hand-assigned hardware registers for 
+   several architectures.
+*/
+
+#if defined(__GNUC__) && !defined(DEBUG)
+#ifdef __mips__
+#define PC_REG asm("$16")
+#define SP_REG asm("$17")
+#define ACCU_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define PC_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define ACCU_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define PC_REG asm("r9")
+#define SP_REG asm("r10")
+#define ACCU_REG asm("r11")
+#define JUMPTBL_BASE_REG asm("r12")
+#else
+#define PC_REG asm("$9")
+#define SP_REG asm("$10")
+#define ACCU_REG asm("$11")
+#define JUMPTBL_BASE_REG asm("$12")
+#endif
+#endif
+#ifdef __i386__
+#define PC_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define ACCU_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define PC_REG asm("26")
+#define SP_REG asm("27")
+#define ACCU_REG asm("28")
+#endif
+#ifdef __hppa__
+#define PC_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define ACCU_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define PC_REG asm("a5")
+#define SP_REG asm("a4")
+#define ACCU_REG asm("d7")
+#endif
+#ifdef __arm__
+#define PC_REG asm("r9")
+#define SP_REG asm("r8")
+#define ACCU_REG asm("r7")
+#endif
+#ifdef __ia64__
+#define PC_REG asm("36")
+#define SP_REG asm("37")
+#define ACCU_REG asm("38")
+#define JUMPTBL_BASE_REG asm("39")
+#endif
+#endif
+
+/* The interpreter itself */
+
+value coq_interprete
+(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args)
+{
+  /*Declaration des variables */
+#ifdef PC_REG
+  register code_t pc PC_REG;
+  register value * sp SP_REG;
+  register value accu ACCU_REG;
+#else
+  register code_t pc;
+  register value * sp;
+  register value accu;
+#endif
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#ifdef JUMPTBL_BASE_REG
+  register char * coq_jumptbl_base JUMPTBL_BASE_REG;
+#else
+  register char * coq_jumptbl_base;
+#endif
+#endif
+#ifdef THREADED_CODE
+  static void * coq_jumptable[] = {
+#    include "coq_jumptbl.h"
+  };
+#else 
+  opcode_t curr_instr;
+#endif
+    print_instr("Enter Interpreter");
+  if (coq_pc == NULL) {           /* Interpreter is initializing */
+    print_instr("Interpreter is initializing");
+#ifdef THREADED_CODE
+    coq_instr_table = (char **) coq_jumptable;
+    coq_instr_base = coq_Jumptbl_base;
+#endif
+    return Val_unit;
+  }
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+  coq_jumptbl_base = coq_Jumptbl_base;
+#endif
+
+  /* Initialisation */
+  sp = coq_sp;
+  pc = coq_pc;
+  accu = coq_accu;
+#ifdef THREADED_CODE
+  goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */
+#else
+  while(1) {
+    curr_instr = *pc++;
+    switch(curr_instr) {
+#endif
+/* Basic stack operations */
+      
+      Instruct(ACC0){
+	print_instr("ACC0");
+	accu = sp[0]; Next;
+      }
+      Instruct(ACC1){
+	print_instr("ACC1");
+	accu = sp[1]; Next;
+      }
+      Instruct(ACC2){
+	print_instr("ACC2");
+	accu = sp[2]; Next;
+      }
+      Instruct(ACC3){
+	print_instr("ACC3");
+	accu = sp[3]; Next;
+      }
+      Instruct(ACC4){
+	print_instr("ACC4");
+	accu = sp[4]; Next;
+      }
+      Instruct(ACC5){
+	print_instr("ACC5");
+	accu = sp[5]; Next;
+      }
+      Instruct(ACC6){
+	print_instr("ACC6");
+	accu = sp[6]; Next;
+      }
+      Instruct(ACC7){
+	print_instr("ACC7");
+        accu = sp[7]; Next;
+      }      
+      Instruct(PUSH){
+	print_instr("PUSH");
+	*--sp = accu; Next;
+      }
+      Instruct(PUSHACC0) {
+	print_instr("PUSHACC0");
+        *--sp = accu; Next;
+      }
+      Instruct(PUSHACC1){
+	print_instr("PUSHACC1");
+        *--sp = accu; accu = sp[1]; Next;
+      }
+      Instruct(PUSHACC2){
+	print_instr("PUSHACC2");
+        *--sp = accu; accu = sp[2]; Next;
+      }
+      Instruct(PUSHACC3){
+	print_instr("PUSHACC3");
+	*--sp = accu; accu = sp[3]; Next;
+      }
+      Instruct(PUSHACC4){
+	print_instr("PUSHACC4");
+	*--sp = accu; accu = sp[4]; Next;
+      }
+      Instruct(PUSHACC5){
+	print_instr("PUSHACC5");
+	*--sp = accu; accu = sp[5]; Next;
+      }
+      Instruct(PUSHACC6){
+	print_instr("PUSHACC5");
+	*--sp = accu; accu = sp[6]; Next;
+      }
+      Instruct(PUSHACC7){
+	print_instr("PUSHACC7");
+	*--sp = accu; accu = sp[7]; Next;
+      }
+      Instruct(PUSHACC){
+	print_instr("PUSHACC");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      
+      Instruct(ACC){
+	print_instr("ACC");
+	accu = sp[*pc++];
+        Next;
+      }
+      
+      Instruct(POP){
+	print_instr("POP");
+	sp += *pc++;
+	Next;
+      }
+      /* Access in heap-allocated environment */
+      
+      Instruct(ENVACC1){
+	print_instr("ENVACC1");
+	accu = Field(coq_env, 1); Next;
+      }
+      Instruct(ENVACC2){
+	print_instr("ENVACC2");
+	accu = Field(coq_env, 2); Next;
+      }
+      Instruct(ENVACC3){
+	print_instr("ENVACC3");
+	accu = Field(coq_env, 3); Next;
+      }
+      Instruct(ENVACC4){
+	print_instr("ENVACC4");
+	accu = Field(coq_env, 4); Next;
+      }
+      Instruct(PUSHENVACC1){
+	print_instr("PUSHENVACC1");
+	*--sp = accu; accu = Field(coq_env, 1); Next;
+      }
+      Instruct(PUSHENVACC2){
+	print_instr("PUSHENVACC2");
+	*--sp = accu; accu = Field(coq_env, 2); Next;
+      }
+      Instruct(PUSHENVACC3){
+	print_instr("PUSHENVACC3");
+	*--sp = accu; accu = Field(coq_env, 3); Next;
+      }
+      Instruct(PUSHENVACC4){
+	print_instr("PUSHENVACC4");
+	*--sp = accu; accu = Field(coq_env, 4); Next;
+      }
+      Instruct(PUSHENVACC){
+	print_instr("PUSHENVACC");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(ENVACC){
+	print_instr("ENVACC");
+	accu = Field(coq_env, *pc++);
+        Next;
+      }
+      /* Function application */
+      
+      Instruct(PUSH_RETADDR) {
+	print_instr("PUSH_RETADDR");
+	sp -= 3;
+	sp[0] = (value) (pc + *pc);
+	sp[1] = coq_env;
+	sp[2] = Val_long(coq_extra_args);
+	coq_extra_args = 0;
+	pc++;
+	Next;
+      }
+      Instruct(APPLY) {
+	print_instr("APPLY");
+	coq_extra_args = *pc - 1;
+	pc = Code_val(accu);
+	coq_env = accu;
+	goto check_stacks;
+      }
+      Instruct(APPLY1) {
+	value arg1 = sp[0];
+	print_instr("APPLY1");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = (value)pc;
+	sp[2] = coq_env;
+	sp[3] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 0;
+	goto check_stacks;
+      }
+      Instruct(APPLY2) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	print_instr("APPLY2");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = (value)pc;
+	sp[3] = coq_env;
+	sp[4] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 1;
+	goto check_stacks;
+      }
+      Instruct(APPLY3) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	value arg3 = sp[2];
+	print_instr("APPLY3");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = arg3;
+	sp[3] = (value)pc;
+	sp[4] = coq_env;
+	sp[5] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 2;
+	goto check_stacks;
+      }
+
+      Instruct(APPTERM) {
+	int nargs = *pc++;
+	int slotsize = *pc;
+	value * newsp;
+	int i;
+	print_instr("APPTERM");
+	/* Slide the nargs bottom words of the current frame to the top
+	   of the frame, and discard the remainder of the frame */
+	newsp = sp + slotsize - nargs;
+	for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
+	sp = newsp;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += nargs - 1;
+	goto check_stacks;
+      }
+      Instruct(APPTERM1) {
+	value arg1 = sp[0];
+	print_instr("APPTERM1");
+	sp = sp + *pc - 1;
+	sp[0] = arg1;
+	pc = Code_val(accu);
+	coq_env = accu;
+	goto check_stacks;
+      }
+      Instruct(APPTERM2) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	print_instr("APPTERM2");
+	sp = sp + *pc - 2;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += 1;
+	goto check_stacks;
+      }
+      Instruct(APPTERM3) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	value arg3 = sp[2];
+	print_instr("APPTERM3");
+	sp = sp + *pc - 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = arg3;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += 2;
+	goto check_stacks;
+      }
+      
+      Instruct(RETURN) {
+	print_instr("RETURN");
+	sp += *pc++;
+	if (coq_extra_args > 0) {
+	  coq_extra_args--;
+	  pc = Code_val(accu);
+	  coq_env = accu;
+	} else {
+	  pc = (code_t)(sp[0]);
+	  coq_env = sp[1];
+	  coq_extra_args = Long_val(sp[2]);
+	  sp += 3;
+	}
+	Next;
+      }
+      
+      Instruct(RESTART) {
+	int num_args = Wosize_val(coq_env) - 2;
+	int i;
+	print_instr("RESTART");
+	sp -= num_args;
+	for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2);
+	coq_env = Field(coq_env, 1);
+	coq_extra_args += num_args;
+	Next;
+      }
+      
+      Instruct(GRAB) {
+	int required = *pc++;
+	print_instr("GRAB");
+	/*	printf("GRAB %d\n",required); */
+	if (coq_extra_args >= required) {
+	  coq_extra_args -= required;
+	} else {
+	  mlsize_t num_args, i;
+	  num_args = 1 + coq_extra_args; /* arg1 + extra args */
+          Alloc_small(accu, num_args + 2, Closure_tag); 
+	  Field(accu, 1) = coq_env;
+	  for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+	  Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
+	  sp += num_args;
+	  pc = (code_t)(sp[0]);
+	  coq_env = sp[1];
+	  coq_extra_args = Long_val(sp[2]);
+	  sp += 3;
+	}
+	Next;
+      }
+
+      Instruct(COGRAB){
+	int required = *pc++;
+	print_instr("COGRAB");
+	if(forcable == Val_true) {
+	  print_instr("true");
+	  /* L'instruction précédante est FORCE */
+	  if (coq_extra_args > 0) coq_extra_args--;
+	  pc++;
+	  forcable = Val_false;
+	} else { /* L'instruction précédante est APPLY */
+	  mlsize_t num_args, i;
+	  num_args = 1 + coq_extra_args; /* arg1 + extra args */
+	  Alloc_small(accu, num_args + 2, Closure_tag); 
+	  Field(accu, 1) = coq_env;
+	  for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+	  Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
+	  sp += num_args;
+	  pc = (code_t)(sp[0]);
+	  coq_env = sp[1];
+	  coq_extra_args = Long_val(sp[2]);
+	  sp += 3;
+	}
+	Next;
+      }
+      Instruct(GRABREC) { 
+	int rec_pos = *pc++; /* commence a zero */
+	print_instr("GRABREC");
+	if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) {
+	  pc++;/* On saute le Restart */
+	} else {
+	  if (coq_extra_args < rec_pos) {
+	    mlsize_t num_args, i;
+	    num_args = 1 + coq_extra_args; /* arg1 + extra args */
+	    Alloc_small(accu, num_args + 2, Closure_tag); 
+	    Field(accu, 1) = coq_env;
+	    for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+	    Code_val(accu) = pc - 3; 
+	    sp += num_args;
+	    pc = (code_t)(sp[0]);
+	    coq_env = sp[1];
+	    coq_extra_args = Long_val(sp[2]);
+	    sp += 3;
+	  } else {
+	    /* L'argument recursif est un accumulateur */
+	    mlsize_t num_args, i;
+	    /* Construction du PF partiellement appliqué */ 
+	    Alloc_small(accu, rec_pos + 2, Closure_tag); 
+	    Field(accu, 1) = coq_env;
+	    for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i];
+	    Code_val(accu) = pc;
+	    sp += rec_pos;
+	    *--sp = accu;
+	      /* Construction de l'atom */
+	    Alloc_small(accu, 2, ATOM_FIX_TAG);
+	    Field(accu,1) = sp[0];
+	    Field(accu,0)  = sp[1];
+	    sp++; sp[0] = accu;
+	      /* Construction de l'accumulateur */
+	    num_args = coq_extra_args - rec_pos;
+	    Alloc_small(accu, 2+num_args, Accu_tag);
+	    Code_val(accu) = accumulate;
+	    Field(accu,1) = sp[0]; sp++;
+	    for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i];
+	    sp += num_args;
+	    pc = (code_t)(sp[0]);
+	    coq_env = sp[1];
+	    coq_extra_args = Long_val(sp[2]);
+	    sp += 3;
+	  }
+	}
+	Next;
+      }
+	
+      Instruct(CLOSURE) {
+	int nvars = *pc++;
+	int i;
+	print_instr("CLOSURE");
+	print_int(nvars);
+	if (nvars > 0) *--sp = accu;
+	Alloc_small(accu, 1 + nvars, Closure_tag);
+	Code_val(accu) = pc + *pc;
+	pc++;
+	for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
+	sp += nvars;
+	Next;
+      }
+
+      Instruct(CLOSUREREC) {
+	int nfuncs = *pc++;
+	int nvars = *pc++;
+	int start = *pc++;
+	int i;
+	value * p;
+	print_instr("CLOSUREREC");
+	if (nvars > 0) *--sp = accu;
+	/* construction du vecteur de type */
+	Alloc_small(accu, nfuncs, 0);
+	for(i = 0; i < nfuncs; i++) {
+	  Field(accu,i) = (value)(pc+pc[i]);
+	}
+	pc += nfuncs;
+	*--sp=accu;
+	Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag);
+	Field(accu, nfuncs * 2 + nvars - 1) = *sp++;
+	/* On remplie la partie pour les variables libres */
+	p = &Field(accu, nfuncs * 2 - 1);
+	for (i = 0; i < nvars; i++) {
+	  *p++ = *sp++;
+	}
+	p = &Field(accu, 0);
+	*p = (value) (pc + pc[0]);
+	p++;
+	for (i = 1; i < nfuncs; i++) {
+	  *p = Make_header(i * 2, Infix_tag, Caml_white);
+	  p++;                                /* color irrelevant. */
+	  *p = (value) (pc + pc[i]);
+	  p++;
+	}
+	pc += nfuncs;
+	accu = accu + 2 * start * sizeof(value);
+	Next;
+      }
+     
+      Instruct(PUSHOFFSETCLOSURE) {
+	print_instr("PUSHOFFSETCLOSURE");
+	*--sp = accu;
+      } /* fallthrough */
+      Instruct(OFFSETCLOSURE) {
+	print_instr("OFFSETCLOSURE");
+	accu = coq_env + *pc++ * sizeof(value); Next;
+      }
+      Instruct(PUSHOFFSETCLOSUREM2) {
+	print_instr("PUSHOFFSETCLOSUREM2");
+	*--sp = accu;
+      } /* fallthrough */
+      Instruct(OFFSETCLOSUREM2) {
+	print_instr("OFFSETCLOSUREM2");
+	accu = coq_env - 2 * sizeof(value); Next;
+      }
+      Instruct(PUSHOFFSETCLOSURE0) {
+	print_instr("PUSHOFFSETCLOSURE0");
+	*--sp = accu; 
+      }/* fallthrough */
+      Instruct(OFFSETCLOSURE0) {
+	print_instr("OFFSETCLOSURE0");
+	accu = coq_env; Next;
+      }
+      Instruct(PUSHOFFSETCLOSURE2){
+	print_instr("PUSHOFFSETCLOSURE2");
+	*--sp = accu; /* fallthrough */
+      }
+      Instruct(OFFSETCLOSURE2) {
+	print_instr("OFFSETCLOSURE2");
+	accu = coq_env + 2 * sizeof(value); Next;
+      }
+
+/* Access to global variables */
+
+      Instruct(PUSHGETGLOBAL) {
+	print_instr("PUSHGETGLOBAL");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(GETGLOBAL){
+	print_instr("GETGLOBAL");
+	accu = Field(coq_global_data, *pc);
+        pc++;
+        Next;
+      }    
+
+/* Allocation of blocks */
+
+      Instruct(MAKEBLOCK) {
+	mlsize_t wosize = *pc++;
+	tag_t tag = *pc++;
+	mlsize_t i;
+	value block;
+	print_instr("MAKEBLOCK");
+	Alloc_small(block, wosize, tag);
+	Field(block, 0) = accu;
+	for (i = 1; i < wosize; i++) Field(block, i) = *sp++;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK1) {
+	
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK1");
+	Alloc_small(block, 1, tag);
+	Field(block, 0) = accu;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK2) {
+	
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK2");
+	Alloc_small(block, 2, tag);
+	Field(block, 0) = accu;
+	Field(block, 1) = sp[0];
+	sp += 1;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK3) {
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK3");
+	Alloc_small(block, 3, tag);
+	Field(block, 0) = accu;
+	Field(block, 1) = sp[0];
+	Field(block, 2) = sp[1];
+	sp += 2;
+	accu = block;
+	Next;
+      }
+
+  
+/* Access to components of blocks */
+        
+	
+/* Branches and conditional branches */
+      Instruct(FORCE) {
+	print_instr("FORCE");
+	if (Is_block(accu) && Tag_val(accu) == Closure_tag) {
+	  forcable = Val_true;
+	  /* On pousse l'addresse de retour et l'argument */
+	  sp -= 3;
+	  sp[0] = (value) (pc - 1);
+	  sp[1] = coq_env;
+	  sp[2] = Val_long(coq_extra_args);
+	  /* On evalue le cofix */
+	  coq_extra_args = 0;
+	  pc = Code_val(accu);
+	  coq_env = accu;
+	  goto check_stacks;
+	} else {
+	  if (Is_block(accu)) print_int(Tag_val(accu));
+	  else print_instr("Not a block");
+	}
+	Next;
+      }
+           
+    
+      Instruct(SWITCH) {
+	uint32 sizes = *pc++;
+	print_instr("SWITCH");
+	print_int(sizes);
+	if (Is_block(accu)) {
+	  long index = Tag_val(accu);
+	  print_instr("block");
+	  print_int(index);
+	  pc += pc[(sizes & 0xFFFF) + index];
+	} else {
+	  long index = Long_val(accu);
+	  print_instr("constant");
+	  print_int(index);
+	  pc += pc[index];
+	}
+	  Next;
+      }
+      Instruct(PUSHFIELD){
+	int i;
+	int size = *pc++;
+	print_instr("PUSHFIELD");
+	sp -= size;
+	for(i=0;i<size;i++)sp[i] = Field(accu,i);
+	Next;
+      }
+	
+      Instruct(MAKESWITCHBLOCK) {
+	mlsize_t sz;
+	int i, annot;
+	code_t typlbl,swlbl;
+	print_instr("MAKESWITCHBLOCK");
+	typlbl = (code_t)pc + *pc; 
+	pc++;
+	swlbl = (code_t)pc + *pc; 
+	pc++;
+	annot = *pc++;
+	sz = *pc++;
+	*--sp = accu;
+	*--sp=Field(coq_global_data, annot);
+	/* On sauve la pile */
+	if (sz == 0) accu = Atom(0);
+	else {
+	  Alloc_small(accu, sz, Default_tag);
+	  if (Field(*sp, 2) == Val_true) {
+	    for (i = 0; i < sz; i++) Field(accu, i) = sp[i+2];
+	  }else{
+	    for (i = 0; i < sz; i++) Field(accu, i) = sp[i+5];
+	  }
+	}
+	*--sp = accu;
+	/* On cree le zipper switch */
+	Alloc_small(accu, 5, Default_tag);
+	Field(accu, 0) =  (value)typlbl; Field(accu, 1) = (value)swlbl; 
+	Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; 
+	Field(accu, 4) = coq_env;
+	sp++;sp[0] = accu;
+	/* On cree l'atome */
+	Alloc_small(accu, 2, ATOM_SWITCH_TAG);
+	Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0];
+	sp++;sp[0] = accu;
+	/* On cree l'accumulateur */
+	Alloc_small(accu, 2, Accu_tag);
+	Code_val(accu) = accumulate; 
+	Field(accu,1) = *sp++;
+	Next;
+      }
+
+      /* Stack checks */
+      
+    check_stacks:
+      print_instr("check_stacks");
+      if (sp < coq_stack_threshold) {
+	coq_sp = sp;
+	realloc_coq_stack(Coq_stack_threshold);
+	sp = coq_sp;
+      }
+      Next;
+      /* Fall through CHECK_SIGNALS */
+
+/* Integer constants */
+
+      Instruct(CONST0){
+	print_instr("CONST0");
+	accu = Val_int(0); Next;}
+      Instruct(CONST1){
+	print_instr("CONST1");
+	accu = Val_int(1); Next;}
+      Instruct(CONST2){
+	print_instr("CONST2");
+	accu = Val_int(2); Next;}
+      Instruct(CONST3){
+	print_instr("CONST3");
+	accu = Val_int(3); Next;}
+      
+      Instruct(PUSHCONST0){
+	print_instr("PUSHCONST0");
+	*--sp = accu; accu = Val_int(0); Next;
+      }
+      Instruct(PUSHCONST1){
+	print_instr("PUSHCONST1");
+	*--sp = accu; accu = Val_int(1); Next;
+      }
+      Instruct(PUSHCONST2){
+	print_instr("PUSHCONST2");
+	*--sp = accu; accu = Val_int(2); Next;
+      }
+      Instruct(PUSHCONST3){
+	print_instr("PUSHCONST3");
+	*--sp = accu; accu = Val_int(3); Next;
+      }
+
+      Instruct(PUSHCONSTINT){
+	print_instr("PUSHCONSTINT");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(CONSTINT) {
+	print_instr("CONSTINT");
+	accu = Val_int(*pc);
+	pc++;
+	Next;
+      }
+
+/* Debugging and machine control */
+
+      Instruct(STOP){
+	print_instr("STOP");
+	coq_sp = sp;
+	return accu;
+      }
+      
+      Instruct(ACCUMULATECOND) {
+	int i, num;
+	print_instr("ACCUMULATECOND");
+	num = *pc;
+	pc++;
+	if (Field(coq_global_boxed, num) == Val_false || coq_all_transp) {
+	  /*	  printf ("false\n");
+	    printf ("tag = %d", Tag_val(Field(accu,1))); */
+	  num = Wosize_val(coq_env);
+	  for(i = 2; i < num; i++) *--sp = Field(accu,i);
+	  coq_extra_args = coq_extra_args + (num - 2);
+	  coq_env = Field(Field(accu,1),1);
+	  pc = Code_val(coq_env);
+	  accu = coq_env;
+	  /*	  printf ("end\n"); */
+	  Next;
+	};
+	/*	printf ("true\n"); */
+      }
+
+      Instruct(ACCUMULATE) {
+	mlsize_t i, size;
+	print_instr("ACCUMULATE");
+	size = Wosize_val(coq_env);
+	Alloc_small(accu, size + coq_extra_args + 1, Accu_tag);
+	for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i);
+	for(i = size; i <= coq_extra_args + size; i++) 
+	  Field(accu, i) = *sp++;
+	pc = (code_t)(sp[0]);
+	coq_env = sp[1];
+	coq_extra_args = Long_val(sp[2]);
+	sp += 3;
+	Next;
+      }  
+            
+      Instruct(MAKEACCU) {
+	int i;
+	print_instr("MAKEACCU");
+	Alloc_small(accu, coq_extra_args + 3, Accu_tag);
+	Code_val(accu) = accumulate;
+	Field(accu,1) = Field(coq_atom_tbl, *pc);
+	for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++;
+	pc = (code_t)(sp[0]);
+	coq_env = sp[1];
+	coq_extra_args = Long_val(sp[2]);
+	sp += 3;
+	Next;
+      }
+     
+      Instruct(MAKEPROD) {
+	print_instr("MAKEPROD");
+	*--sp=accu;
+	Alloc_small(accu,2,0);
+	Field(accu, 0) = sp[0];
+	Field(accu, 1) = sp[1];
+	sp += 2;
+	Next;
+      }
+      
+#ifndef THREADED_CODE
+    default:
+      /*fprintf(stderr, "%d\n", *pc);*/
+      failwith("Coq VM: Fatal error: bad opcode");
+    }
+  }
+#endif
+}
+
+value coq_push_ra(value tcode) { 
+  print_instr("push_ra");
+  coq_sp -= 3;
+  coq_sp[0] = (value) tcode;
+  coq_sp[1] = Val_unit;
+  coq_sp[2] = Val_long(0);
+  return Val_unit;
+}
+
+value coq_push_val(value v) {
+  print_instr("push_val");
+  *--coq_sp = v;
+  return Val_unit;
+}
+
+value coq_push_arguments(value args) {
+  int nargs,i;
+  nargs = Wosize_val(args) - 2;
+  coq_sp -= nargs;
+  print_instr("push_args");print_int(nargs);
+  for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2);
+  return Val_unit;
+}
+
+value coq_push_vstack(value stk) {
+  int len,i;
+  len = Wosize_val(stk);
+  coq_sp -= len;
+  print_instr("push_vstack");print_int(len);
+   for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i);
+  return Val_unit;
+}
+
+value  coq_interprete_ml(value tcode, value a, value e, value ea) {
+  print_instr("coq_interprete");
+  return coq_interprete((code_t)tcode, a, e, Long_val(ea));
+   print_instr("end coq_interprete");
+}
+
+value coq_eval_tcode (value tcode, value e) {
+  return coq_interprete_ml(tcode, Val_unit, e, 0);
+}
diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h
new file mode 100644
index 00000000..76e68944
--- /dev/null
+++ b/kernel/byterun/coq_interp.h
@@ -0,0 +1,23 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+
+value coq_push_ra(value tcode);
+
+value coq_push_val(value v);
+
+value coq_push_arguments(value args);
+
+value coq_push_vstack(value stk);
+
+value  coq_interprete_ml(value tcode, value a, value e, value ea);
+
+value coq_eval_tcode (value tcode, value e);
+
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
new file mode 100644
index 00000000..db6aacb9
--- /dev/null
+++ b/kernel/byterun/coq_memory.c
@@ -0,0 +1,273 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include <string.h> 
+#include "coq_gc.h"
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+#include "coq_memory.h"
+
+/* stack */
+
+value * coq_stack_low;
+value * coq_stack_high;
+value * coq_stack_threshold;
+asize_t coq_max_stack_size = Coq_max_stack_size;
+/* global_data */
+
+
+value coq_global_data;
+value coq_global_boxed;
+int coq_all_transp;
+value coq_atom_tbl;
+
+int drawinstr;
+/* interp state */
+
+long coq_saved_sp_offset;
+value * coq_sp;
+value forcable;
+/* Some predefined pointer code */ 
+code_t accumulate;
+
+/* functions over global environment */
+
+void coq_stat_free (void * blk)
+{
+  free (blk);
+}
+
+value coq_static_alloc(value size) /* ML */
+{
+  return (value) coq_stat_alloc((asize_t) Long_val(size));
+}
+
+value coq_static_free(value blk)  /* ML */
+{
+  coq_stat_free((void *) blk);
+  return Val_unit;
+}
+
+value accumulate_code(value unit) /* ML */
+{
+  return (value) accumulate;
+}
+
+static void (*coq_prev_scan_roots_hook) (scanning_action);
+
+static void coq_scan_roots(scanning_action action)
+{
+  register value * i;
+  /* Scan the global variables */
+  (*action)(coq_global_data, &coq_global_data);
+  (*action)(coq_global_boxed, &coq_global_boxed);
+  (*action)(coq_atom_tbl, &coq_atom_tbl);
+  /* Scan the stack */
+  for (i = coq_sp; i < coq_stack_high; i++) {
+    (*action) (*i, i);
+  };
+  /* Hook */
+  if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action);
+
+
+}
+
+void init_coq_stack()
+{
+  coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size);
+  coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value);
+  coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value);
+  coq_max_stack_size = Coq_max_stack_size;
+}  
+
+void init_coq_global_data(long requested_size)
+{
+  int i;
+  coq_global_data = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) 
+    Field (coq_global_data, i) = Val_unit;
+}
+
+void init_coq_global_boxed(long requested_size)
+{
+  int i;
+  coq_global_boxed = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) 
+    Field (coq_global_boxed, i) = Val_true;
+}
+
+void init_coq_atom_tbl(long requested_size){
+  int i;
+  coq_atom_tbl = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit;
+}
+
+void init_coq_interpreter()
+{
+  coq_sp = coq_stack_high;
+  coq_interprete(NULL, Val_unit, Val_unit, 0);
+}
+
+static int coq_vm_initialized = 0;
+
+value init_coq_vm(value unit) /* ML */
+{
+  int i;
+  if (coq_vm_initialized == 1) {
+    fprintf(stderr,"already open \n");fflush(stderr);}
+  else {
+    drawinstr=0;
+#ifdef THREADED_CODE   
+    init_arity();
+#endif /* THREADED_CODE */
+    /* Allocate the table of global and the stack */
+    init_coq_stack();
+    init_coq_global_data(Coq_global_data_Size);
+    init_coq_global_boxed(40);
+    init_coq_atom_tbl(40);
+    /* Initialing the interpreter */
+    coq_all_transp = 0;
+    forcable = Val_false;
+    init_coq_interpreter();
+    
+    /* Some predefined pointer code */
+    accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t));
+    *accumulate = VALINSTR(ACCUMULATE);
+
+  /* Initialize GC */
+    if (coq_prev_scan_roots_hook == NULL)
+      coq_prev_scan_roots_hook = scan_roots_hook;
+    scan_roots_hook = coq_scan_roots;
+    coq_vm_initialized = 1;
+  } 
+  return Val_unit;;
+}
+
+void realloc_coq_stack(asize_t required_space)
+{
+  asize_t size;
+  value * new_low, * new_high, * new_sp;
+  value * p;
+  size = coq_stack_high - coq_stack_low;
+  do {
+    size *= 2;
+  } while (size < coq_stack_high - coq_sp + required_space);
+  new_low = (value *) coq_stat_alloc(size * sizeof(value));
+  new_high = new_low + size;
+
+#define shift(ptr) \
+    ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr)))
+
+  new_sp = (value *) shift(coq_sp);
+  memmove((char *) new_sp,
+        (char *) coq_sp,
+        (coq_stack_high - coq_sp) * sizeof(value));
+  coq_stat_free(coq_stack_low);
+  coq_stack_low = new_low;
+  coq_stack_high = new_high;
+  coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value);
+  coq_sp = new_sp;
+#undef shift
+}
+
+value get_coq_global_data(value unit)                /* ML */
+{
+  return coq_global_data;
+}
+
+value get_coq_atom_tbl(value unit)                  /* ML */
+{
+  return coq_atom_tbl;
+}
+
+value get_coq_global_boxed(value unit)        /* ML */
+{
+  return coq_global_boxed;
+}
+
+value realloc_coq_global_data(value size)           /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_global_data;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_global_data);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_global_data = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_global_data, i), Field(coq_global_data, i));
+    for (i = actual_size; i < requested_size; i++){
+      Field (new_global_data, i) = Val_long (0);
+    }
+    coq_global_data = new_global_data;
+  }
+  return Val_unit;
+}
+
+value realloc_coq_global_boxed(value size)           /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_global_boxed;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_global_boxed);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_global_boxed = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i));
+    for (i = actual_size; i < requested_size; i++)
+      Field (new_global_boxed, i) = Val_long (0);
+    coq_global_boxed = new_global_boxed;
+  }
+  return Val_unit;
+}
+
+value realloc_coq_atom_tbl(value size)            /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_atom_tbl;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_atom_tbl);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_atom_tbl = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i));
+    for (i = actual_size; i < requested_size; i++)
+      Field (new_atom_tbl, i) = Val_long (0);
+    coq_atom_tbl = new_atom_tbl;
+  }
+  return Val_unit;
+}
+
+
+value coq_set_transp_value(value transp)
+{
+  coq_all_transp = (transp == Val_true);
+  return Val_unit;
+}
+
+value get_coq_transp_value(value unit)
+{
+  return Val_bool(coq_all_transp);
+}
+
+value coq_set_drawinstr(value unit)
+{
+  drawinstr = 1;
+  return Val_unit;
+}
+
+value coq_set_forcable (value unit)
+{
+  forcable = Val_true;
+  return Val_unit;
+}
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
new file mode 100644
index 00000000..7c96e684
--- /dev/null
+++ b/kernel/byterun/coq_memory.h
@@ -0,0 +1,70 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_MEMORY_
+#define _COQ_MEMORY_
+
+#include "config.h"
+#include "fail.h"
+#include "misc.h"
+#include "memory.h"
+#include "mlvalues.h"
+
+
+#define Coq_stack_size (4096 * sizeof(value))
+#define Coq_stack_threshold (256 * sizeof(value))
+#define Coq_global_data_Size (4096 * sizeof(value))
+#define Coq_max_stack_size (256 * 1024)
+
+#define TRANSP 0
+#define BOXED 1
+
+/* stack */
+
+extern value * coq_stack_low;
+extern value * coq_stack_high;
+extern value * coq_stack_threshold;
+
+/* global_data */
+
+extern value coq_global_data;
+extern value coq_global_boxed;
+extern int coq_all_transp;
+extern value coq_atom_tbl;
+
+extern int drawinstr;
+/* interp state */
+
+extern value * coq_sp;
+extern value forcable;
+/* Some predefined pointer code */ 
+extern code_t accumulate;
+
+/* functions over global environment */
+
+value coq_static_alloc(value size);  /* ML */
+value coq_static_free(value string); /* ML */
+
+value init_coq_vm(value unit); /* ML */
+value re_init_coq_vm(value unit); /* ML */
+
+void  realloc_coq_stack(asize_t required_space); 
+value get_coq_global_data(value unit); /* ML */
+value realloc_coq_global_data(value size); /* ML */
+value get_coq_global_boxed(value unit);
+value realloc_coq_global_boxed(value size); /* ML */
+value get_coq_atom_tbl(value unit); /* ML */
+value realloc_coq_atom_tbl(value size); /* ML */
+value coq_set_transp_value(value transp); /* ML */
+value get_coq_transp_value(value unit); /* ML */
+#endif /* _COQ_MEMORY_ */
+
+
+value coq_set_drawinstr(value unit);
diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c
new file mode 100644
index 00000000..baf3ab09
--- /dev/null
+++ b/kernel/byterun/coq_values.c
@@ -0,0 +1,69 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include "coq_fix_code.h"
+#include "coq_instruct.h"
+#include "coq_memory.h"
+#include "coq_values.h"
+#include "memory.h"
+/* KIND OF VALUES */
+
+#define Setup_for_gc
+#define Restore_after_gc
+
+value coq_kind_of_closure(value v) {
+  opcode_t * c;
+  int res;
+  int is_app = 0;
+  c = Code_val(v);
+  if (Is_instruction(c, GRAB)) return Val_int(0);
+  if (Is_instruction(c, RESTART)) {is_app = 1; c++;}
+  if (Is_instruction(c, GRABREC)) return Val_int(1+is_app);
+  if (Is_instruction(c, COGRAB)) return Val_int(3+is_app);
+  if (Is_instruction(c, MAKEACCU)) return Val_int(5);
+  return Val_int(0);
+}
+
+
+/* DESTRUCT ACCU */
+
+value coq_closure_arity(value clos) {
+  opcode_t * c = Code_val(clos);
+  if (Is_instruction(c,RESTART)) {
+    c++;
+    if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
+    else { 
+      if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
+      return Val_int(1);
+    }
+  }
+  if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]);
+  return Val_int(1);
+}
+
+/* Fonction sur les  fix */
+
+value coq_offset(value v) {
+  if (Tag_val(v) == Closure_tag) return Val_int(0);
+  else return Val_long(-Wsize_bsize(Infix_offset_val(v)));
+}
+
+value coq_offset_closure(value v, value offset){
+  return (value)&Field(v, Int_val(offset));
+}
+
+value coq_offset_tcode(value code,value offset){
+  return((value)((code_t)code + Int_val(offset)));
+}
+
+value coq_int_tcode(value code, value offset) {
+  return Val_int(*((code_t) code + Int_val(offset)));
+}
diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h
new file mode 100644
index 00000000..a186d62a
--- /dev/null
+++ b/kernel/byterun/coq_values.h
@@ -0,0 +1,28 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_VALUES_
+#define _COQ_VALUES_
+
+#include "alloc.h"
+#include "mlvalues.h"
+
+#define ATOM_FIX_TAG 3
+#define ATOM_SWITCH_TAG 4
+
+#define Accu_tag 0
+#define Default_tag 0
+
+/* Les blocs accumulate */
+#define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag))
+
+#endif /* _COQ_VALUES_ */
+
+
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
new file mode 100644
index 00000000..49955474
--- /dev/null
+++ b/kernel/cbytecodes.ml
@@ -0,0 +1,120 @@
+open Names
+open Term
+
+type tag = int 
+
+type structured_constant =
+  | Const_sorts of sorts
+  | Const_ind of inductive
+  | Const_b0 of tag                
+  | Const_bn of tag * structured_constant array
+
+type reloc_table = (tag * int) array 
+
+type annot_switch = 
+   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+ 
+module Label = 
+  struct
+    type t = int
+    let no = -1
+    let counter = ref no
+    let create () = incr counter; !counter
+    let reset_label_counter () = counter := no 
+  end
+
+
+type instruction =
+  | Klabel of Label.t
+  | Kacc of int
+  | Kenvacc of int
+  | Koffsetclosure of int
+  | Kpush
+  | Kpop of int
+  | Kpush_retaddr of Label.t
+  | Kapply of int                       (*  number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Kjump
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kgrabrec of int                     (* rec arg *)
+  | Kcograb of int                      (* number of arguments *)
+  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | Kclosurerec of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kgetglobal of constant
+  | Kconst of structured_constant
+  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeprod 
+  | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
+  | Kforce
+  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kpushfield of int 
+  | Kstop
+  | Ksequence of bytecodes * bytecodes
+
+and bytecodes = instruction list
+
+type fv_elem = FVnamed of identifier | FVrel of int
+
+type fv = fv_elem array
+
+
+(* --- Pretty print *)
+open Format
+let rec instruction ppf = function
+  | Klabel lbl -> fprintf ppf "L%i:" lbl
+  | Kacc n -> fprintf ppf "\tacc %i" n
+  | Kenvacc n -> fprintf ppf "\tenvacc %i" n
+  | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n
+  | Kpush -> fprintf ppf "\tpush"
+  | Kpop n -> fprintf ppf "\tpop %i" n
+  | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl
+  | Kapply n -> fprintf ppf "\tapply %i" n
+  | Kappterm(n, m) ->
+      fprintf ppf "\tappterm %i, %i" n m
+  | Kreturn n -> fprintf ppf "\treturn %i" n
+  | Kjump -> fprintf ppf "\tjump"
+  | Krestart -> fprintf ppf "\trestart"
+  | Kgrab n -> fprintf ppf "\tgrab %i" n
+  | Kgrabrec n -> fprintf ppf "\tgrabrec %i" n
+  | Kcograb n -> fprintf ppf "\tcograb %i" n
+  | Kclosure(lbl, n) ->
+      fprintf ppf "\tclosure L%i, %i" lbl n
+  | Kclosurerec(fv,init,lblt,lblb) ->
+      fprintf ppf "\tclosurerec";
+      fprintf ppf "%i , %i, " fv init;
+      print_string "types = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt;
+      print_string " bodies = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
+  | Kconst cst ->
+      fprintf ppf "\tconst"
+  | Kmakeblock(n, m) ->
+      fprintf ppf "\tmakeblock %i, %i" n m
+  | Kmakeprod -> fprintf ppf "\tmakeprod"
+  | Kmakeswitchblock(lblt,lbls,_,sz) ->
+      fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz
+  | Kforce -> fprintf ppf "\tforce"
+  | Kswitch(lblc,lblb) -> 
+      fprintf ppf "\tswitch";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc;
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
+  | Kpushfield n -> 
+      fprintf ppf "\tpushfield %i" n
+  | Kstop -> fprintf ppf "\tstop"
+  | Ksequence (c1,c2) ->
+      fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 
+
+and instruction_list ppf = function
+    [] -> ()
+  | Klabel lbl :: il ->
+      fprintf ppf "L%i:%a" lbl instruction_list il
+  | instr :: il ->
+      fprintf ppf "%a@ %a" instruction instr instruction_list il
+ 
+let draw_instr c =
+  fprintf std_formatter "@[<v 0>%a@]" instruction_list c
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
new file mode 100644
index 00000000..a996f750
--- /dev/null
+++ b/kernel/cbytecodes.mli
@@ -0,0 +1,61 @@
+open Names
+open Term
+
+type tag = int 
+
+type structured_constant =
+  | Const_sorts of sorts
+  | Const_ind of inductive
+  | Const_b0 of tag                
+  | Const_bn of tag * structured_constant array
+
+type reloc_table = (tag * int) array 
+
+type annot_switch = 
+   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+
+module Label : 
+  sig
+    type t = int
+    val no : t
+    val create : unit -> t
+    val reset_label_counter : unit -> unit
+  end 
+
+type instruction =
+  | Klabel of Label.t
+  | Kacc of int
+  | Kenvacc of int
+  | Koffsetclosure of int
+  | Kpush
+  | Kpop of int
+  | Kpush_retaddr of Label.t
+  | Kapply of int                       (*  number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Kjump
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kgrabrec of int                     (* rec arg *)
+  | Kcograb of int                      (* number of arguments *)
+  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | Kclosurerec of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kgetglobal of constant
+  | Kconst of structured_constant
+  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeprod 
+  | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
+  | Kforce
+  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kpushfield of int 
+  | Kstop
+  | Ksequence of bytecodes * bytecodes
+
+and bytecodes = instruction list
+
+type fv_elem = FVnamed of identifier | FVrel of int
+
+type fv = fv_elem array
+
+val draw_instr : bytecodes -> unit
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
new file mode 100644
index 00000000..041e0795
--- /dev/null
+++ b/kernel/cbytegen.ml
@@ -0,0 +1,490 @@
+open Util
+open Names
+open Cbytecodes
+open Cemitcodes
+open Term
+open Declarations
+open Pre_env
+
+(*i Compilation des variables + calcul des variables libres *)
+
+(* Representation des environnements machines :                       *)
+(*[t0|C0| ... |tc|Cc| ... |t(nbr-1)|C(nbr-1)| fv1 | fv1 | .... | fvn] *)
+(*               ^<----------offset--------->                         *)
+
+
+type fv = fv_elem list
+
+type vm_env = {size : int; fv_rev : fv}
+    (* size = n;   fv_rev = [fvn; ... ;fv1] *)
+         
+type t = {
+    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 : int;         (* position de la fonction courante = c *)
+    offset : int;          
+    in_env : vm_env ref
+  }	
+
+let empty_fv = {size= 0; fv_rev = []}
+
+let fv r = !(r.in_env)
+
+(* [add_param n] rend la liste [sz+1;sz+2;...;sz+n] *)
+let rec add_param n sz l =
+  if n = 0 then l else add_param (n - 1) sz (n+sz::l) 
+
+(* [push_param ] ajoute les parametres de fonction dans la pile *)
+let push_param n sz r =
+  { r with
+    nb_stack = r.nb_stack + n;
+    in_stack = add_param n sz r.in_stack }
+
+(* [push_local e sz] ajoute une nouvelle variable dans la pile a la position *)
+let push_local sz r = 
+  { r with 
+    nb_stack = r.nb_stack + 1;
+    in_stack = (sz + 1) :: r.in_stack }
+
+(* Table de relocation initiale *)
+let empty () = 
+  { nb_stack = 0; in_stack = [];
+    nb_rec = 0;pos_rec = 0;
+    offset = 0; in_env = ref empty_fv }
+
+let init_fun arity = 
+  { nb_stack = arity; in_stack = add_param arity 0 [];
+    nb_rec = 0; pos_rec = 0;
+    offset = 1; in_env = ref empty_fv } 
+
+let init_type ndef rfv =
+  { nb_stack = 0; in_stack = [];
+    nb_rec = 0; pos_rec = 0;
+    offset = 2*(ndef-1)+1; in_env = rfv }
+
+let init_fix ndef pos_rec arity rfv =
+  { nb_stack = arity; in_stack = add_param arity 0 [];
+    nb_rec = ndef; pos_rec = pos_rec;
+    offset = 2 * (ndef - pos_rec - 1)+1; in_env = rfv} 
+
+let find_at el l = 
+  let rec aux n = function
+    | [] -> raise Not_found
+    | hd :: tl -> if hd = el then n else aux (n+1) tl
+  in aux 1 l
+
+let pos_named id r =
+  let env = !(r.in_env) in
+  let cid = FVnamed id in
+  try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev))
+  with Not_found ->
+    let pos = env.size in
+    r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
+    Kenvacc (r.offset + pos)
+
+let pos_rel i r sz = 
+  if i <= r.nb_stack then
+    Kacc(sz - (List.nth r.in_stack (i-1)))
+  else if i <= r.nb_stack + r.nb_rec 
+  then Koffsetclosure (2 * (r.nb_rec + r.nb_stack - r.pos_rec - i))
+  else 
+    let db = FVrel(i - r.nb_stack - r.nb_rec) in
+    let env = !(r.in_env) in
+    try Kenvacc(r.offset + env.size - (find_at db env.fv_rev))
+    with Not_found ->
+      let pos = env.size in
+      r.in_env := { size = pos+1; fv_rev =  db:: env.fv_rev};
+      Kenvacc(r.offset + pos)
+
+
+(*i  Examination of the continuation *)
+
+(* Discard all instructions up to the next label.
+   This function is to be applied to the continuation before adding a
+   non-terminating instruction (branch, raise, return, appterm)
+   in front of it. *)
+
+let rec discard_dead_code cont = cont
+(*function
+    [] -> []
+  | (Klabel _ | Krestart ) :: _ as cont -> cont
+  | _ :: cont -> discard_dead_code cont
+*)
+
+(* Return a label to the beginning of the given continuation.
+   If the sequence starts with a branch, use the target of that branch
+   as the label, thus avoiding a jump to a jump. *)
+
+let label_code = function
+  | Klabel 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. *)
+
+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
+
+(* Check if we're in tailcall position *)
+
+let rec is_tailcall = function
+  | Kreturn k :: _ -> Some k
+  | Klabel _ :: c -> is_tailcall c
+  | _ -> None
+
+(* Extention of the continuation ****)
+	
+(* Add a Kpop n instruction in front of a continuation *)
+let rec add_pop n = function
+  | Kpop m :: cont -> add_pop (n+m) cont
+  | Kreturn m:: cont -> Kreturn (n+m) ::cont
+  | cont -> if n = 0 then cont else Kpop n :: cont
+
+let add_grab arity lbl cont =
+  if arity = 1 then Klabel lbl :: cont
+  else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont
+ 
+
+(* Environnement global *****)
+
+let global_env = ref empty_env
+
+let set_global_env env = global_env := env
+
+
+(* Code des fermetures ****)
+let fun_code = ref []
+
+let init_fun_code () = fun_code := []
+
+(* Compilation des constructeurs et des inductifs *)
+
+(* Inv : nparam + arity > 0 *)
+let code_construct tag nparams arity cont =
+  let f_cont =
+      add_pop nparams
+      (if arity = 0 then 
+	[Kconst (Const_b0 tag); Kreturn 0]
+       else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0])
+    in 
+    let lbl = Label.create() in
+    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 =
+  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) -> 
+	    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)
+	    else  
+	      let b_args = Array.map str_const args in
+	      Bconstruct_app(num, nparams, arity, b_args)
+	| _ -> 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,[||])
+  | _ -> Bconstr c
+
+(* compilation des applications *)
+let comp_args comp_expr reloc args sz cont =
+  let nargs_m_1 = Array.length args - 1 in  
+  let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in
+  for i = 1 to nargs_m_1 do
+    c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c)
+  done; 
+  !c
+  
+let comp_app comp_fun comp_arg reloc f args sz cont =
+  let nargs = Array.length args in
+  match is_tailcall cont with
+  | Some k -> 
+      comp_args comp_arg reloc args sz
+	(Kpush ::
+	 comp_fun reloc f (sz + nargs)
+	   (Kappterm(nargs, k + nargs) :: (discard_dead_code cont)))
+  | None ->
+      if nargs < 4 then
+	comp_args comp_arg reloc args sz
+	  (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont)))
+      else 
+	let lbl,cont1 = label_code cont in
+	Kpush_retaddr lbl ::
+	(comp_args comp_arg reloc args (sz + 3)
+	   (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1))))
+
+(* Compilation des variables libres *)
+  
+let compile_fv_elem reloc fv sz cont =
+  match fv with
+  | FVrel i -> pos_rel i reloc sz :: cont
+  | FVnamed id -> pos_named id reloc :: cont
+
+(* compilation des constantes *)
+
+let rec get_allias env kn =
+  let tps = (lookup_constant kn env).const_body_code in
+  match Cemitcodes.force tps with
+  | BCallias kn' -> get_allias env kn'
+  | _ -> kn
+
+(* compilation des expressions *)
+ 
+let rec compile_constr reloc c sz cont =
+  match kind_of_term c with
+  | Meta _ -> raise (Invalid_argument "Cbytegen.gen_lam : Meta")
+  | Evar _ -> raise (Invalid_argument "Cbytegen.gen_lam : Evar")
+ 
+  | Cast(c,_,_) -> 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
+  
+  | Sort _  | Ind _ | Construct _ ->
+      compile_str_cst reloc (str_const c) sz cont
+  
+  | LetIn(_,xb,_,body) ->
+      compile_constr reloc xb sz 
+	(Kpush :: 
+	(compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont)))
+  | Prod(id,dom,codom) ->
+      let cont1 = 
+	Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in
+      compile_constr reloc (mkLambda(id,dom,codom)) sz cont1
+  | Lambda _ ->
+      let params, body = decompose_lam c in
+      let arity = List.length params in
+      let r_fun = init_fun arity in
+      let lbl_fun = Label.create() in
+      let cont_fun = 
+	compile_constr r_fun body arity [Kreturn arity] in
+      fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)];
+      let fv = fv r_fun in
+      compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
+ 
+  | App(f,args) -> 
+      begin 
+	match kind_of_term f with
+	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
+	| _ -> comp_app compile_constr compile_constr reloc f args sz cont 
+      end
+  | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
+      let ndef = Array.length type_bodies in
+      let rfv = ref empty_fv in
+      let lbl_types = Array.create ndef Label.no in
+      let lbl_bodies = Array.create ndef Label.no in
+      (* Compilation des types *)
+      let rtype = init_type ndef rfv in
+      for i = 0 to ndef - 1 do
+	let lbl,fcode = 
+	  label_code 
+	    (compile_constr rtype type_bodies.(i) 0 [Kstop]) in 
+	lbl_types.(i) <- lbl; 
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      (* Compilation des corps *)
+      for i = 0 to ndef - 1 do
+	let params,body = decompose_lam rec_bodies.(i) in
+	let arity = List.length params in
+	let rbody = init_fix ndef i arity rfv in
+	let cont1 = 
+	  compile_constr rbody body arity [Kreturn arity] in
+	let lbl = Label.create () in
+	lbl_bodies.(i) <- lbl;
+	let fcode =  
+	  if arity = 1 then 
+	    Klabel lbl :: Kgrabrec 0 :: Krestart :: cont1
+	  else
+	    Krestart :: Klabel lbl :: Kgrabrec rec_args.(i) ::
+	    Krestart :: Kgrab (arity - 1) :: cont1
+	in
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      let fv = !rfv in
+      compile_fv reloc fv.fv_rev sz 
+	(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
+  
+  | CoFix(init,(_,type_bodies,rec_bodies)) ->
+      let ndef = Array.length type_bodies in
+      let rfv = ref empty_fv in
+      let lbl_types = Array.create ndef Label.no in
+      let lbl_bodies = Array.create ndef Label.no in
+      (* Compilation des types *)
+      let rtype = init_type ndef rfv in
+      for i = 0 to ndef - 1 do
+	let lbl,fcode = 
+	  label_code 
+	    (compile_constr rtype type_bodies.(i) 0 [Kstop]) in
+	lbl_types.(i) <- lbl; 
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      (* Compilation des corps *)
+      for i = 0 to ndef - 1 do
+	let params,body = decompose_lam rec_bodies.(i) in
+	let arity = List.length params in
+	let rbody = init_fix ndef i arity rfv in
+	let lbl = Label.create () in
+
+	let cont1 = 
+	  compile_constr rbody body arity [Kreturn(arity)] in
+	let cont2 = 
+	  if arity <= 1 then cont1 else Kgrab (arity - 1) :: cont1 in
+	let cont3 = 
+	  Krestart :: Klabel lbl :: Kcograb arity :: Krestart :: cont2 in
+	fun_code := [Ksequence(cont3,!fun_code)];
+	lbl_bodies.(i) <- lbl
+      done;
+      let fv = !rfv in
+      compile_fv reloc fv.fv_rev sz 
+	(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
+  
+  | Case(ci,t,a,branchs) ->
+      let ind = ci.ci_ind in
+      let mib = lookup_mind (fst ind) !global_env in
+      let oib = mib.mind_packets.(snd ind) in
+      let tbl = oib.mind_reloc_tbl in
+      let lbl_consts = Array.create oib.mind_nb_constant Label.no in
+      let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
+      let branch1,cont = make_branch cont in
+      (* Compilation du type *)
+      let lbl_typ,fcode = 	
+	label_code (compile_constr reloc t sz [Kpop sz; Kstop])
+      in fun_code := [Ksequence(fcode,!fun_code)];
+      (* Compilation des branches *) 
+      let lbl_sw = Label.create () in
+      let sz_b,branch,is_tailcall =
+	match branch1 with 
+	| Kreturn k -> assert (k = sz); sz, branch1, true
+	| _ -> sz+3, Kjump, false
+      in
+      let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
+     (* Compilation de la branche accumulate *)
+      let lbl_accu, code_accu = 
+	label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) 
+      in
+      lbl_blocks.(0) <- lbl_accu;
+      let c = ref code_accu in
+      (* Compilation des branches constructeurs *)
+      for i = 0 to Array.length tbl - 1 do
+	let tag, arity = tbl.(i) in
+	if arity = 0 then
+	  let lbl_b,code_b = 
+	    label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in
+	  lbl_consts.(tag) <- lbl_b; 
+	  c := code_b
+	else 
+	  let args, body = decompose_lam branchs.(i) in
+	  let nargs = List.length args in
+	  let lbl_b,code_b = 
+	    label_code(
+	    if nargs = arity then
+	      Kpushfield arity ::
+	      compile_constr (push_param arity sz_b reloc)
+		body (sz_b+arity) (add_pop arity (branch :: !c))
+	    else
+	      let sz_appterm = if is_tailcall then sz_b + arity else arity in
+	      Kpushfield arity :: 
+	      compile_constr reloc branchs.(i) (sz_b+arity)
+		(Kappterm(arity,sz_appterm) :: !c))
+	  in
+	  lbl_blocks.(tag) <- lbl_b;
+	  c := code_b
+      done;
+      c :=  Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c;
+      let code_sw = 
+	match branch1 with
+	| Klabel lbl -> Kpush_retaddr lbl ::  !c
+	| _ -> !c 
+      in
+      let cont_a = if mib.mind_finite then code_sw else Kforce :: code_sw in
+      compile_constr reloc a sz cont_a 
+ 
+and compile_fv reloc l sz cont =
+  match l with
+  | [] -> cont
+  | [fvn] -> compile_fv_elem reloc fvn sz cont
+  | fvn :: tl ->
+      compile_fv_elem reloc fvn sz 
+	(Kpush :: compile_fv reloc tl (sz + 1) cont)
+      
+and compile_str_cst reloc sc sz cont =
+  match sc with
+  | Bconstr c -> compile_constr reloc c sz cont
+  | Bstrconst sc -> Kconst sc :: cont
+  | Bmakeblock(tag,args) ->
+      let nargs = Array.length args in
+      comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont)
+  | Bconstruct_app(tag,nparams,arity,args) ->
+      if Array.length args = 0 then code_construct tag nparams arity cont
+      else
+	comp_app 
+	  (fun _ _ _ cont -> code_construct tag nparams arity cont) 
+	  compile_str_cst reloc () args sz cont
+      
+let compile env c =
+  set_global_env env;
+  init_fun_code ();
+  Label.reset_label_counter ();
+  let reloc = empty () in
+  let init_code = compile_constr reloc c 0 [Kstop] in
+  let fv = List.rev (!(reloc.in_env).fv_rev) in
+  init_code,!fun_code, Array.of_list fv
+
+let compile_constant_body env body opaque boxed =
+  if opaque then BCconstant
+  else match body with
+  | None -> BCconstant
+  | Some sb ->
+      let body = Declarations.force sb in
+      if boxed then
+	let res = compile env body in
+	let to_patch = to_memory res in
+	BCdefined(true, to_patch)
+      else
+	match kind_of_term body with
+	| Const kn' -> BCallias (get_allias env kn')
+	| _ -> 
+	    let res = compile env body in
+	    let to_patch = to_memory res in
+	    BCdefined (false, to_patch)
+
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
new file mode 100644
index 00000000..f761e4f6
--- /dev/null
+++ b/kernel/cbytegen.mli
@@ -0,0 +1,17 @@
+open Names
+open Cbytecodes
+open Cemitcodes 
+open Term
+open Declarations
+open Pre_env
+
+
+
+val compile : env -> constr -> bytecodes * bytecodes * fv
+                              (* init, fun, fv *)
+
+val compile_constant_body : 
+    env -> constr_substituted option -> bool -> bool -> body_code
+                                 (* opaque *) (* boxed *)
+
+
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
new file mode 100644
index 00000000..cccb1844
--- /dev/null
+++ b/kernel/cemitcodes.ml
@@ -0,0 +1,303 @@
+open Names
+open Term
+open Cbytecodes
+open Copcodes
+open Mod_subst
+
+(* Relocation information *)
+type reloc_info =
+  | Reloc_annot of annot_switch 
+  | Reloc_const of structured_constant
+  | Reloc_getglobal of constant
+
+type patch = reloc_info * int 
+
+let patch_int buff pos n =
+  String.unsafe_set buff pos (Char.unsafe_chr n);
+  String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+  String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+  String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
+
+
+(* Buffering of bytecode *)
+
+let out_buffer = ref(String.create 1024)
+and out_position = ref 0
+
+let out_word b1 b2 b3 b4 =
+  let p = !out_position in
+  if p >= String.length !out_buffer then begin
+    let len = String.length !out_buffer in
+    let new_buffer = String.create (2 * len) in
+    String.blit !out_buffer 0 new_buffer 0 len;
+    out_buffer := new_buffer
+  end;
+  String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
+  String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
+  String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
+  String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
+  out_position := p + 4
+
+let out opcode =
+  out_word opcode 0 0 0
+
+let out_int n =
+  out_word n (n asr 8) (n asr 16) (n asr 24)
+
+(* Handling of local labels and backpatching *)
+
+type label_definition =
+    Label_defined of int
+  | Label_undefined of (int * int) list
+
+let label_table  = ref ([| |] : label_definition array)
+(* le ieme element de la table = Label_defined n signifie que l'on a 
+   deja rencontrer le label i et qu'il est a l'offset n.
+                               = Label_undefined l signifie que l'on a 
+   pas encore rencontrer ce label, le premier entier indique ou est l'entier 
+   a patcher dans la string, le deuxieme son origine  *)
+
+let extend_label_table needed =
+  let new_size = ref(Array.length !label_table) in
+  while needed >= !new_size do new_size := 2 * !new_size done;
+  let new_table = Array.create !new_size (Label_undefined []) in
+  Array.blit !label_table 0 new_table 0 (Array.length !label_table);
+  label_table := new_table
+
+let backpatch (pos, orig) =
+  let displ = (!out_position - orig) asr 2 in
+  !out_buffer.[pos] <- Char.unsafe_chr displ;
+  !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
+  !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
+  !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+
+let define_label lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined _ ->
+      raise(Failure "CEmitcode.define_label")
+  | Label_undefined patchlist ->
+      List.iter backpatch patchlist;
+      (!label_table).(lbl) <- Label_defined !out_position
+
+let out_label_with_orig orig lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined def ->
+      out_int((def - orig) asr 2)
+  | Label_undefined patchlist ->
+      if patchlist = [] then
+	(!label_table).(lbl) <-
+          Label_undefined((!out_position, orig) :: patchlist);
+      out_int 0
+
+let out_label l = out_label_with_orig !out_position l
+
+(* Relocation information *)
+
+let reloc_info = ref ([] : (reloc_info * int) list)
+
+let enter info =
+  reloc_info := (info, !out_position) :: !reloc_info
+
+let slot_for_const c =
+  enter (Reloc_const c);
+  out_int 0
+
+and slot_for_annot a =
+  enter (Reloc_annot a);
+  out_int 0
+
+and slot_for_getglobal id =
+  enter (Reloc_getglobal id);
+  out_int 0
+
+
+(* Emission of one instruction *)
+
+
+let emit_instr = function
+  | Klabel lbl -> define_label lbl
+  | Kacc n ->
+      if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
+  | Kenvacc n ->
+      if n >= 1 && n <= 4
+      then out(opENVACC1 + n - 1)
+      else (out opENVACC; out_int n)
+  | Koffsetclosure ofs ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out (opOFFSETCLOSURE0 + ofs / 2)
+      else (out opOFFSETCLOSURE; out_int ofs)
+  | Kpush ->      
+      out opPUSH
+  | Kpop n ->      
+      out opPOP; out_int n
+  | Kpush_retaddr lbl -> 
+      out opPUSH_RETADDR; out_label lbl
+  | Kapply n ->
+      if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
+  | Kappterm(n, sz) ->
+      if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
+               else (out opAPPTERM; out_int n; out_int sz)
+  | Kreturn n ->
+      out opRETURN; out_int n
+  | Kjump ->
+      out opRETURN; out_int 0
+  | Krestart ->
+      out opRESTART
+  | Kgrab n -> 
+      out opGRAB; out_int n
+  | Kgrabrec(rec_arg) -> 
+      out opGRABREC; out_int rec_arg
+  | Kcograb n -> 
+      out opCOGRAB; out_int n
+  | Kclosure(lbl, n) -> 
+      out opCLOSURE; out_int n; out_label lbl
+  | Kclosurerec(nfv,init,lbl_types,lbl_bodies) ->
+      out opCLOSUREREC;out_int (Array.length lbl_bodies);
+      out_int nfv; out_int init;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_types;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_bodies
+  | Kgetglobal q -> 
+      out opGETGLOBAL; slot_for_getglobal q
+  | Kconst((Const_b0 i)) -> 
+      if i >= 0 && i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i) 
+  | Kconst c ->
+      out opGETGLOBAL; slot_for_const c
+  | Kmakeblock(n, t) ->
+      if n = 0 then raise (Invalid_argument "emit_instr : block size = 0")
+      else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
+      else (out opMAKEBLOCK; out_int n; out_int t)
+  | Kmakeprod ->
+      out opMAKEPROD
+  | Kmakeswitchblock(typlbl,swlbl,annot,sz) ->
+      out opMAKESWITCHBLOCK;
+      out_label typlbl; out_label swlbl;
+      slot_for_annot annot;out_int sz
+  | Kforce -> 
+      out opFORCE
+  | Kswitch (tbl_const, tbl_block) ->
+      out opSWITCH;
+      out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) tbl_const;
+      Array.iter (out_label_with_orig org) tbl_block
+  | Kpushfield n ->
+      out opPUSHFIELD;out_int n
+  | Kstop -> 
+      out opSTOP
+  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
+
+(* Emission of a list of instructions. Include some peephole optimization. *)
+
+let rec emit = function
+  | [] -> ()
+  (* Peephole optimizations *)
+  | Kpush :: Kacc n :: c ->
+      if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
+      emit c
+  | Kpush :: Kenvacc n :: c -> 
+      if n >= 1 && n <= 4
+      then out(opPUSHENVACC1 + n - 1)
+      else (out opPUSHENVACC; out_int n);
+      emit c
+  | Kpush :: Koffsetclosure ofs :: c -> 
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
+      else (out opPUSHOFFSETCLOSURE; out_int ofs);
+      emit c
+  | Kpush :: Kgetglobal id :: c ->
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c 
+  | Kpush :: Kconst (Const_b0 i) :: c -> 
+      if i >= 0 && i <= 3
+      then out (opPUSHCONST0 + i)
+      else (out opPUSHCONSTINT; out_int i);
+      emit c
+  | Kpush :: Kconst const :: c ->
+      out opPUSHGETGLOBAL; slot_for_const const;
+      emit c 
+  | Kpop n :: Kjump :: c ->
+      out opRETURN; out_int n; emit c
+  | Ksequence(c1,c2)::c ->
+      emit c1; emit c2;emit c
+  (* Default case *)
+  | instr :: c ->
+      emit_instr instr; emit c
+
+(* Initialization *)
+
+let init () =
+  out_position := 0;
+  label_table := Array.create 16 (Label_undefined []);
+  reloc_info := []
+
+type emitcodes = string
+
+let length = String.length
+
+type to_patch = emitcodes * (patch list) * fv
+
+(* Substitution *)
+let rec subst_strcst s sc =
+  match sc with
+  | Const_sorts _ | Const_b0 _ -> sc
+  | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
+  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i))
+
+let subst_patch s (ri,pos) = 
+  match ri with
+  | Reloc_annot a ->
+      let (kn,i) = a.ci.ci_ind in
+      let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in
+      (Reloc_annot {a with ci = ci},pos)
+  | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos)
+  | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos)
+
+let subst_to_patch s (code,pl,fv) = 
+  code,List.rev_map (subst_patch s) pl,fv
+
+type body_code =
+  | BCdefined of bool * to_patch
+  | BCallias of constant
+  | BCconstant
+
+let subst_body_code s = function
+  | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp)
+  | BCallias kn -> BCallias (fst (subst_con s kn))
+  | BCconstant -> BCconstant
+
+type to_patch_substituted = body_code substituted
+
+let from_val = from_val
+
+let force = force subst_body_code
+
+let subst_to_patch_subst = subst_substituted 
+
+let is_boxed tps =
+  match force tps with
+  | BCdefined(b,_) -> b
+  | _ -> false
+
+let to_memory (init_code, fun_code, fv) =
+  init();
+  emit init_code;
+  emit fun_code;
+  let code = String.create !out_position in
+  String.unsafe_blit !out_buffer 0 code 0 !out_position;
+  let reloc = List.rev !reloc_info in
+  Array.iter (fun lbl -> 
+    (match lbl with
+      Label_defined _ -> assert true
+    | Label_undefined patchlist -> 
+	assert (patchlist = []))) !label_table;
+  (code, reloc, fv)
+
+
+
+
+
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
new file mode 100644
index 00000000..ca6da65e
--- /dev/null
+++ b/kernel/cemitcodes.mli
@@ -0,0 +1,40 @@
+open Names
+open Cbytecodes
+
+type reloc_info =
+  | Reloc_annot of annot_switch 
+  | Reloc_const of structured_constant
+  | Reloc_getglobal of constant
+
+type patch = reloc_info * int 
+(* A virer *)
+val subst_patch : Mod_subst.substitution -> patch -> patch
+ 
+type emitcodes 
+
+val length : emitcodes -> int 
+
+val patch_int : emitcodes -> (*pos*)int -> int -> unit
+
+type to_patch = emitcodes * (patch list) * fv
+
+val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
+
+type body_code =
+  | BCdefined of bool*to_patch
+  | BCallias of constant
+  | BCconstant
+
+
+type to_patch_substituted 
+
+val from_val : body_code -> to_patch_substituted 
+
+val force : to_patch_substituted -> body_code
+
+val is_boxed : to_patch_substituted -> bool
+
+val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
+
+val to_memory : bytecodes * bytecodes * fv -> to_patch
+               (* init code, fun code, fv *) 
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 1a635ccf..8e16a922 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml,v 1.54.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+(* $Id: closure.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
 
 open Util
 open Pp
@@ -16,7 +16,6 @@ open Declarations
 open Environ
 open Esubst
 
-
 let stats = ref false
 let share = ref true
 
@@ -52,10 +51,8 @@ let with_stats c =
   end else
     Lazy.force c
 
-type transparent_state = Idpred.t * KNpred.t
-
-let all_opaque = (Idpred.empty, KNpred.empty)
-let all_transparent = (Idpred.full, KNpred.full)
+let all_opaque = (Idpred.empty, Cpred.empty)
+let all_transparent = (Idpred.full, Cpred.full)
 
 module type RedFlagsSig = sig
   type reds
@@ -110,7 +107,7 @@ module RedFlags = (struct
     | DELTA -> { red with r_delta = true; r_const = all_transparent }
     | CONST kn ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = l1, KNpred.add kn l2 }
+	{ red with r_const = l1, Cpred.add kn l2 }
     | IOTA -> { red with r_iota = true }
     | ZETA -> { red with r_zeta = true }
     | VAR id ->
@@ -122,7 +119,7 @@ module RedFlags = (struct
     | DELTA -> { red with r_delta = false }
     | CONST kn ->
  	let (l1,l2) = red.r_const in
-	{ red with r_const = l1, KNpred.remove kn l2 }
+	{ red with r_const = l1, Cpred.remove kn l2 }
     | IOTA -> { red with r_iota = false }
     | ZETA -> { red with r_zeta = false }
     | VAR id ->
@@ -138,7 +135,7 @@ module RedFlags = (struct
     | BETA -> incr_cnt red.r_beta beta
     | CONST kn -> 
 	let (_,l) = red.r_const in
-	let c = KNpred.mem kn l in
+	let c = Cpred.mem kn l in
 	incr_cnt c delta
     | VAR id -> (* En attendant d'avoir des kn pour les Var *)
 	let (l,_) = red.r_const in
@@ -152,7 +149,7 @@ module RedFlags = (struct
   let red_get_const red =
     let p1,p2 = red.r_const in
     let (b1,l1) = Idpred.elements p1 in
-    let (b2,l2) = KNpred.elements p2 in
+    let (b2,l2) = Cpred.elements p2 in
     if b1=b2 then
       let l1' = List.map (fun x -> EvalVarRef x) l1 in
       let l2' = List.map (fun x -> EvalConstRef x) l2 in
@@ -326,11 +323,7 @@ fin obsolète **************)
  * instantiations (cbv or lazy) are.
  *)
 
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
-  | FarRelKey of int
-   (* FarRel: index in the rel_context part of _initial_ environment *)
+type table_key = id_key
 
 type 'a infos = {
   i_flags : reds;
@@ -349,7 +342,7 @@ let ref_value_cache info ref =
   try
     let body =
       match ref with
-	| FarRelKey n ->
+	| RelKey n ->
 	    let (s,l) = info.i_rels in lift n (List.assoc (s-n) l)
 	| VarKey id -> List.assoc id info.i_vars
 	| ConstKey cst -> constant_value info.i_env cst
@@ -364,22 +357,22 @@ let ref_value_cache info ref =
 
 let defined_vars flags env =
 (*  if red_local_const (snd flags) then*)
-    fold_named_context 
-      (fun env (id,b,t) e ->
+    Sign.fold_named_context 
+      (fun (id,b,_) e ->
 	 match b with
 	   | None -> e
 	   | Some body -> (id, body)::e)
-      env ~init:[]
+       (named_context env) ~init:[]
 (*  else []*)
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  fold_rel_context 
-      (fun env (id,b,t) (i,subs) ->
+  Sign.fold_rel_context 
+      (fun (id,b,t) (i,subs) ->
 	 match b with
 	   | None -> (i+1, subs)
 	   | Some body -> (i+1, (i,body) :: subs))
-      env ~init:(0,[])
+      (rel_context env) ~init:(0,[])
 (*  else (0,[])*)
 
 
@@ -519,7 +512,7 @@ type fconstr = {
 and fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * fconstr
+  | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -539,6 +532,8 @@ let fterm_of v = v.term
 let set_norm v = v.norm <- Norm
 let is_val v = v.norm = Norm
 
+let mk_atom c = {norm=Norm;term=FAtom c}
+
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
 let update v1 (no,t) =
@@ -553,7 +548,7 @@ let update v1 (no,t) =
    when the lift is 0. *)
 let rec lft_fconstr n ft =
   match ft.term with
-    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FAtom _) -> ft
+    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft
     | FRel i -> {norm=Norm;term=FRel(i+n)}
     | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))}
     | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))}
@@ -573,7 +568,7 @@ let clos_rel e i =
     | Inl(n,mt) -> lift_fconstr n mt
     | Inr(k,None) -> {norm=Norm; term= FRel k}
     | Inr(k,Some p) ->
-        lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)}
+        lift_fconstr (k-p) {norm=Norm;term=FFlex(RelKey p)}
 
 (* since the head may be reducible, we might introduce lifts of 0 *)
 let compact_stack head stk =
@@ -608,10 +603,10 @@ let rec compact_constr (lg, subs as s) c k =
     | Evar(ev,v) ->
         let (v',s) = compact_vect s v k in
         if v==v' then c,s else mkEvar(ev,v'),s
-    | Cast(a,b) ->
+    | Cast(a,ck,b) ->
         let (a',s) = compact_constr s a k in
         let (b',s) = compact_constr s b k in
-        if a==a' && b==b' then c,s else mkCast(a',b'), s
+        if a==a' && b==b' then c,s else mkCast(a', ck, b'), s
     | App(f,v) ->
         let (f',s) = compact_constr s f k in
         let (v',s) = compact_vect s v k in
@@ -664,7 +659,7 @@ let optimise_closure env c =
     (env',c')
 
 let mk_lambda env t =
-(*  let (env,t) = optimise_closure env t in*)
+  let (env,t) = optimise_closure env t in
   let (rvars,t') = decompose_lam t in
   FLambda(List.length rvars, List.rev rvars, t', env)
 
@@ -698,9 +693,9 @@ let mk_clos_deep clos_fun env t =
   match kind_of_term t with
     | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) ->
         mk_clos env t
-    | Cast (a,b) ->
+    | Cast (a,k,b) ->
         { norm = Red;
-          term = FCast (clos_fun env a, clos_fun env b)}
+          term = FCast (clos_fun env a, k, clos_fun env b)}
     | App (f,v) ->
         { norm = Red;
 	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
@@ -730,15 +725,11 @@ let mk_clos2 = mk_clos_deep mk_clos
 let rec to_constr constr_fun lfts v =
   match v.term with
     | FRel i -> mkRel (reloc_rel i lfts)
-    | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts)
+    | FFlex (RelKey p) -> mkRel (reloc_rel p lfts)
     | FFlex (VarKey x) -> mkVar x
-    | FAtom c ->
-        (match kind_of_term c with
-          | Sort s -> mkSort s
-          | Meta m -> mkMeta m
-          | _ -> assert false)
-    | FCast (a,b) ->
-        mkCast (constr_fun lfts a, constr_fun lfts b)
+    | FAtom c -> exliftn lfts c
+    | FCast (a,k,b) ->
+        mkCast (constr_fun lfts a, k, constr_fun lfts b)
     | FFlex (ConstKey op) -> mkConst op
     | FInd op -> mkInd op
     | FConstruct op -> mkConstruct op
@@ -808,23 +799,23 @@ let rec fstrong unfreeze_fun lfts v =
   to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
 *)
 
-let rec zip zfun m stk =
+let rec zip m stk =
   match stk with
     | [] -> m
     | Zapp args :: s ->
         let args = Array.of_list args in
-        zip zfun {norm=neutr m.norm; term=FApp(m, Array.map zfun args)} s
+        zip {norm=neutr m.norm; term=FApp(m, args)} s
     | Zcase(ci,p,br)::s ->
-        let t = FCases(ci, zfun p, m, Array.map zfun br) in
-        zip zfun {norm=neutr m.norm; term=t} s
+        let t = FCases(ci, p, m, br) in
+        zip {norm=neutr m.norm; term=t} s
     | Zfix(fx,par)::s ->
-        zip zfun fx (par @ append_stack_list ([m], s))
+        zip fx (par @ append_stack_list ([m], s))
     | Zshift(n)::s ->
-        zip zfun (lift_fconstr n m) s
+        zip (lift_fconstr n m) s
     | Zupdate(rf)::s ->
-        zip zfun (update rf (m.norm,m.term)) s
+        zip (update rf (m.norm,m.term)) s
 
-let fapp_stack (m,stk) = zip (fun x -> x) m stk
+let fapp_stack (m,stk) = zip m stk
 
 (*********************************************************************)
 
@@ -849,7 +840,7 @@ let strip_update_shift_app head stk =
   let rec strip_rec rstk h depth = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
-    | (Zapp args :: s) as stk ->
+    | (Zapp args :: s) ->
         strip_rec (Zapp args :: rstk)
           {norm=h.norm;term=FApp(h,Array.of_list args)} depth s
     | Zupdate(m)::s ->
@@ -892,7 +883,7 @@ let get_arg h stk =
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
-        let hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        let _hd = update r (Cstr,FLambda(n,tys,f,e)) in
         get_args n tys f e s
     | Zshift k :: s ->
         get_args n tys f (subs_shft (k,e)) s
@@ -985,7 +976,7 @@ let rec knh m stk =
         (match get_nth_arg m ri.(n) stk with
              (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk')
            | (None, stk') -> (m,stk'))
-    | FCast(t,_) -> knh t stk
+    | FCast(t,_,_) -> knh t stk
 (* cases where knh stops *)
     | (FFlex _|FLetIn _|FConstruct _|FEvar _|
        FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
@@ -999,7 +990,7 @@ and knht e t stk =
     | Case(ci,p,t,br) ->
         knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk)
     | Fix _ -> knh (mk_clos2 e t) stk
-    | Cast(a,b) -> knht e a stk
+    | Cast(a,_,_) -> knht e a stk
     | Rel n -> knh (clos_rel e n) stk
     | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
        LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
@@ -1023,8 +1014,8 @@ let rec knr info m stk =
       (match ref_value_cache info (VarKey id) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
-  | FFlex(FarRelKey k) when red_set info.i_flags fDELTA ->
-      (match ref_value_cache info (FarRelKey k) with
+  | FFlex(RelKey k) when red_set info.i_flags fDELTA ->
+      (match ref_value_cache info (RelKey k) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
   | FConstruct(ind,c) when red_set info.i_flags fIOTA ->
diff --git a/kernel/closure.mli b/kernel/closure.mli
index e58b91eb..706a089e 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,v 1.42.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: closure.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Pp
@@ -27,7 +27,7 @@ val with_stats: 'a Lazy.t -> 'a
   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
   a LetIn expression is Letin reduction *)
 
-type transparent_state = Idpred.t * KNpred.t
+
 
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
@@ -82,13 +82,8 @@ val betadeltaiotanolet : reds
 
 val unfold_red : evaluable_global_reference -> reds
 
-(************************************************************************)
-
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
-  | FarRelKey of int
-   (* FarRel: index in the [rel_context] part of {\em initial} environment *)
+(***********************************************************************)
+type table_key = id_key
 
 type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
@@ -120,6 +115,7 @@ val stack_args_size : 'a stack -> int
 val app_stack : constr * constr stack -> constr
 val stack_tail : int -> 'a stack -> 'a stack
 val stack_nth : 'a stack -> int -> 'a
+val zip_term : ('a -> constr) -> constr -> 'a stack -> constr
 
 (************************************************************************)
 (*s Lazy reduction. *)
@@ -134,7 +130,7 @@ type fconstr
 type fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * fconstr
+  | FCast of fconstr * cast_kind * fconstr 
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -159,6 +155,8 @@ val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
 val destFLambda :
   (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+(* mk_atom: prevents a term from being evaluated *)
+val mk_atom : constr -> fconstr
 
 (* Global and local constant cache *)
 type clos_infos
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index dba373ce..4c692308 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -6,18 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml,v 1.2.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+(* $Id: conv_oracle.ml 6303 2004-11-16 12:37:40Z sacerdot $ *)
 
 open Names
-open Closure
 
 (* Opaque constants *)
-let cst_transp = ref KNpred.full
+let cst_transp = ref Cpred.full
 
-let set_opaque_const kn = cst_transp := KNpred.remove kn !cst_transp
-let set_transparent_const kn = cst_transp := KNpred.add kn !cst_transp
+let set_opaque_const kn = cst_transp := Cpred.remove kn !cst_transp
+let set_transparent_const kn = cst_transp := Cpred.add kn !cst_transp
 
-let is_opaque_cst kn = not (KNpred.mem kn !cst_transp)
+let is_opaque_cst kn = not (Cpred.mem kn !cst_transp)
 
 (* Opaque variables *)
 let var_transp = ref Idpred.full
@@ -31,13 +30,13 @@ let is_opaque_var kn = not (Idpred.mem kn !var_transp)
 let is_opaque = function
   | ConstKey cst -> is_opaque_cst cst
   | VarKey id -> is_opaque_var id
-  | FarRelKey _ -> false
+  | RelKey _ -> false
 
 (* Unfold the first only if it is not opaque and the second is opaque *)
 let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1)
 
 (* summary operations *)
-
-let init() = (cst_transp := KNpred.full; var_transp := Idpred.full)
+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)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 8d0c12bb..966edd1d 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli,v 1.3.8.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: conv_oracle.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 open Names
-open Closure
+
 
 (* Order on section paths for unfolding.
    If [oracle_order kn1 kn2] is true, then unfold kn1 first.
    Note: the oracle does not introduce incompleteness, it only
    tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : table_key -> table_key -> bool
+val oracle_order : 'a tableKey -> 'a tableKey -> bool
 
 (* Changing the oracle *)
 val set_opaque_const      : constant -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index d69efe3a..a6aa2a8e 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,v 1.17.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: cooking.ml 6748 2005-02-18 22:17:50Z herbelin $ i*)
 
 open Pp
 open Util
@@ -19,154 +19,110 @@ open Reduction
 
 (*s Cooking the constants. *)
 
-type 'a modification =
-  | NOT_OCCUR
-  | DO_ABSTRACT of 'a * constr array
-  | DO_REPLACE of constant_body
+type work_list = identifier array Cmap.t * identifier array KNmap.t
 
-type work_list =
-    (constant * constant modification) list
-    * (inductive * inductive modification) list
-    * (constructor * constructor modification) list
+let dirpath_prefix p = match repr_dirpath p with
+  | [] -> anomaly "dirpath_prefix: empty dirpath"
+  | _::l -> make_dirpath l
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : identifier list;
-  d_modlist : work_list }
+let pop_kn kn =
+  let (mp,dir,l) = Names.repr_kn kn in
+  Names.make_kn mp (dirpath_prefix dir) l
+
+let pop_con con = 
+  let (mp,dir,l) = Names.repr_con con in
+  Names.make_con mp (dirpath_prefix dir) l
+
+type my_global_reference =
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t)
+
+let clear_cooking_sharing () = Hashtbl.clear cache
+
+let share r (cstl,knl) =
+  try Hashtbl.find cache r
+  with Not_found ->
+  let f,l =
+    match r with
+    | IndRef (kn,i) -> 
+	mkInd (pop_kn kn,i), KNmap.find kn knl
+    | ConstructRef ((kn,i),j) -> 
+	mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl
+    | ConstRef cst ->
+	mkConst (pop_con cst), Cmap.find cst cstl in
+  let c = mkApp (f, Array.map mkVar l) in
+  Hashtbl.add cache r c;
+  (* has raised Not_found if not in work_list *)
+  c
 
-let failure () =
-  anomalylabstrm "generic__modify_opers"
-    (str"An oper which was never supposed to appear has just appeared" ++
-     spc () ++ str"Either this is in system code, and you need to" ++ spc () ++
-     str"report this error," ++ spc () ++
-     str"Or you are using a user-written tactic which calls" ++ spc () ++
-     str"generic__modify_opers, in which case the user-written code" ++
-     spc () ++ str"is broken - this function is an internal system" ++
-     spc () ++ str"for internal system use only")
-
-let modify_opers replfun (constl,indl,cstrl) =
+let update_case_info ci modlist =
+  try
+    let ind, n = 
+      match kind_of_term (share (IndRef ci.ci_ind) modlist) with
+      | App (f,l) -> (destInd f, Array.length l)
+      | Ind ind -> ind, 0
+      | _ -> assert false in
+    { ci with ci_ind = ind; ci_npar = ci.ci_npar + n }
+  with Not_found ->
+    ci
+
+let empty_modlist = (Cmap.empty, KNmap.empty)
+
+let expmod_constr modlist c =
   let rec substrec c =
-    let c' = map_constr substrec c in
-    match kind_of_term c' with
+    match kind_of_term c with
       | Case (ci,p,t,br) ->
+	  map_constr substrec (mkCase (update_case_info ci modlist,p,t,br))
+
+      | Ind ind ->
 	  (try
-	     match List.assoc ci.ci_ind indl with
-	       | DO_ABSTRACT (ind,abs_vars) ->
-		   let n' = Array.length abs_vars + ci.ci_npar in
-                   let ci' = { ci with
-                               ci_ind = ind;
-                               ci_npar = n' } in
-		   mkCase (ci',p,t,br)
-	       | _ -> raise Not_found
-	   with
-	     | Not_found -> c')
-
-      | Ind spi ->
-	  (try
-	     (match List.assoc spi indl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-                    mkApp (mkInd oper', abs_vars)
-		| DO_REPLACE _ -> assert false)
+	    share (IndRef ind) modlist
 	   with 
-	     | Not_found -> c')
-
-      | Construct spi ->
+	    | Not_found -> map_constr substrec c)
+	  
+      | Construct cstr ->
 	  (try
-	     (match List.assoc spi cstrl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-		    mkApp (mkConstruct oper', abs_vars)
-		| DO_REPLACE _ -> assert false)
+	    share (ConstructRef cstr) modlist
 	   with 
-	     | Not_found -> c')
-
-      | Const kn ->
+	    | Not_found -> map_constr substrec c)
+	  
+      | Const cst ->
 	  (try
-	     (match List.assoc kn constl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-		    mkApp (mkConst oper', abs_vars)
-		| DO_REPLACE cb -> substrec (replfun (kn,cb)))
+	    share (ConstRef cst) modlist
 	   with 
-	     | Not_found -> c')
-  
-    | _ -> c'
-  in 
-  if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec
+	    | Not_found -> map_constr substrec c)
+
+  | _ -> map_constr substrec c
 
-let expmod_constr modlist c =
-  let simpfun = 
-    if modlist = ([],[],[]) then fun x -> x else nf_betaiota in
-  let expfun (kn,cb) = 
-    if cb.const_opaque then
-      errorlabstrm "expmod_constr"
-	(str"Cannot unfold the value of " ++
-        str(string_of_kn kn) ++ spc () ++
-        str"You cannot declare local lemmas as being opaque" ++ spc () ++
-        str"and then require that theorems which use them" ++ spc () ++
-        str"be transparent");
-    match cb.const_body with
-      | Some body -> Declarations.force body
-      | None -> assert false
-  in
-  let c' = modify_opers expfun modlist c in
-  match kind_of_term c' with
-    | Cast (value,typ) -> mkCast (simpfun value,simpfun typ)
-    | _ -> simpfun c'
-
-let expmod_type modlist c =
-  type_app (expmod_constr modlist) c
-
-let abstract_constant ids_to_abs hyps (body,typ) =
-  let abstract_once_typ ((hyps,typ) as sofar) id =
-    match hyps with
-      | (hyp,c,t as decl)::rest when hyp = id ->
-	  let typ' = mkNamedProd_wo_LetIn decl typ in
-	  (rest, typ')
-      | _ -> 
-	  sofar
-  in
-  let abstract_once_body ((hyps,body) as sofar) id =
-    match hyps with
-      | (hyp,c,t as decl)::rest when hyp = id ->
-	  let body' = mkNamedLambda_or_LetIn decl body in
-	  (rest, body')
-      | _ -> 
-	  sofar
-  in
-  let (_,typ') =
-    List.fold_left abstract_once_typ (hyps,typ) ids_to_abs 
-  in
-  let body' = match body with
-      None -> None
-    | Some l_body -> 
-	Some (Declarations.from_val
-		(let body = Declarations.force l_body in
-		 let (_,body') = 
-		   List.fold_left abstract_once_body (hyps,body) ids_to_abs
-		 in
-		   body'))
   in
-    (body',typ')
+  if modlist = empty_modlist then c
+  else under_outer_cast nf_betaiota (substrec c)
+
+let abstract_constant_type =
+   List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
+
+let abstract_constant_body =
+  List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c)
+
+type recipe = {
+  d_from : constant_body;
+  d_abstract : named_context;
+  d_modlist : work_list }
+
+let on_body f = 
+  option_app (fun c -> Declarations.from_val (f (Declarations.force c)))
 
 let cook_constant env r =
   let cb = r.d_from in
-  let typ = expmod_type r.d_modlist cb.const_type in
-  let body = 
-    option_app 
-      (fun lconstr -> 
-	 Declarations.from_val 
-	   (expmod_constr r.d_modlist (Declarations.force lconstr))) 
-      cb.const_body
-  in
-  let hyps =
-    Sign.fold_named_context
-      (fun d ctxt ->
-        Sign.add_named_decl
-          (map_named_declaration (expmod_constr r.d_modlist) d)
-          ctxt)
-      cb.const_hyps
-      ~init:empty_named_context in
-  let body,typ = abstract_constant r.d_abstract hyps (body,typ) in
-  (body, typ, cb.const_constraints, cb.const_opaque)
+  let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
+  let body =
+    on_body (fun c ->
+      abstract_constant_body (expmod_constr r.d_modlist c) hyps) 
+      cb.const_body in
+  let typ =
+    abstract_constant_type (expmod_constr r.d_modlist cb.const_type) hyps in
+  let boxed = Cemitcodes.is_boxed cb.const_body_code in
+  (body, typ, cb.const_constraints, cb.const_opaque, boxed)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index 54526e99..7b51ac0c 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,v 1.9.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: cooking.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
 
 open Names
 open Term
@@ -16,27 +16,22 @@ open Univ
 
 (*s Cooking the constants. *)
 
-type 'a modification =
-  | NOT_OCCUR
-  | DO_ABSTRACT of 'a * constr array
-  | DO_REPLACE of constant_body
-
-type work_list =
-    (constant * constant modification) list
-    * (inductive * inductive modification) list
-    * (constructor * constructor modification) list
+type work_list = identifier array Cmap.t * identifier array KNmap.t
 
 type recipe = {
   d_from : constant_body;
-  d_abstract : identifier list;
+  d_abstract : Sign.named_context;
   d_modlist : work_list }
 
 val cook_constant :
-  env -> recipe -> constr_substituted option * constr * constraints * bool
+  env -> recipe -> 
+    constr_substituted option * constr * constraints * bool * bool
 
 (*s Utility functions used in module [Discharge]. *)
 
 val expmod_constr : work_list -> constr -> constr
-val expmod_type : work_list -> types -> types
+
+val clear_cooking_sharing : unit -> unit
+
 
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
new file mode 100644
index 00000000..fc2d0925
--- /dev/null
+++ b/kernel/csymtable.ml
@@ -0,0 +1,179 @@
+open Names
+open Term
+open Vm
+open Cemitcodes
+open Cbytecodes
+open Declarations
+open Pre_env
+open Cbytegen
+
+
+external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
+external free_tcode : tcode -> unit = "coq_static_free"
+external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
+ 
+(*******************)
+(* Linkage du code *)
+(*******************)
+
+(* Table des globaux *)
+
+(* [global_data] contient les valeurs des constantes globales 
+   (axiomes,definitions), les annotations des switch et les structured 
+   constant *)
+external global_data : unit -> values array = "get_coq_global_data"
+
+(* [realloc_global_data n] augmente de n la taille de [global_data] *)
+external realloc_global_data : int -> unit = "realloc_coq_global_data"
+
+let check_global_data n =
+  if n >= Array.length (global_data()) then realloc_global_data n
+  
+let num_global = ref 0
+
+let set_global v = 
+  let n = !num_global in
+  check_global_data n;
+  (global_data()).(n) <- v;
+  incr num_global;
+  n
+
+(* [global_transp],[global_boxed] contiennent les valeurs des 
+   definitions gelees. Les deux versions sont maintenues en //. 
+   [global_transp] contient la version transparente.
+   [global_boxed] contient la version gelees. *)
+
+external global_boxed : unit -> bool array = "get_coq_global_boxed"
+
+(* [realloc_global_data n] augmente de n la taille de [global_data] *)
+external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
+
+let check_global_boxed n =
+  if n >= Array.length (global_boxed()) then realloc_global_boxed n
+  
+let num_boxed = ref 0
+
+let boxed_tbl = Hashtbl.create 53
+
+let cst_opaque = ref Cpred.full
+
+let is_opaque kn = Cpred.mem kn !cst_opaque
+
+let set_global_boxed kn v = 
+  let n = !num_boxed in
+  check_global_boxed n;
+  (global_boxed()).(n) <- (is_opaque kn);
+  Hashtbl.add boxed_tbl kn n ;
+  incr num_boxed;
+  set_global (val_of_constant_def n kn v)
+
+(* table pour les structured_constant et les annotations des switchs *)
+
+let str_cst_tbl = Hashtbl.create 31
+    (* (structured_constant * int) Hashtbl.t*)
+
+let annot_tbl = Hashtbl.create 31
+    (* (annot_switch * int) Hashtbl.t  *)
+
+(*************************************************************)
+(*** Mise a jour des valeurs des variables et des constantes *)
+(*************************************************************)
+
+exception NotEvaluated
+
+let key rk =
+  match !rk with
+  | Some k -> k
+  | _ -> raise NotEvaluated
+
+(************************)
+(* traduction des patch *)
+
+(* slot_for_*, calcul la valeur de l'objet, la place
+   dans la table global, rend sa position dans la table *)
+ 
+let slot_for_str_cst key =
+  try Hashtbl.find str_cst_tbl key 
+  with Not_found -> 
+    let n = set_global (val_of_str_const key) in
+    Hashtbl.add str_cst_tbl key n;
+    n
+
+let slot_for_annot key =
+  try Hashtbl.find annot_tbl key 
+  with Not_found -> 
+    let n =  set_global (Obj.magic key) in
+    Hashtbl.add annot_tbl key n;
+    n
+
+let rec slot_for_getglobal env kn =
+  let (cb,rk) = lookup_constant_key kn env in
+  try key rk
+  with NotEvaluated ->
+    let pos =
+      match Cemitcodes.force cb.const_body_code with
+      | BCdefined(boxed,(code,pl,fv)) -> 
+	let v = eval_to_patch env (code,pl,fv) in
+  	if boxed then set_global_boxed kn v 
+	else set_global v 
+    | BCallias kn' -> slot_for_getglobal env kn' 
+    | BCconstant -> set_global (val_of_constant kn) in
+    rk := Some pos;
+    pos
+
+and slot_for_fv env fv=
+  match fv with
+  | FVnamed id -> 
+      let nv = 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
+      end
+  | FVrel i ->
+      let rv = 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
+      end
+ 
+and eval_to_patch env (buff,pl,fv) = 
+  let patch = function
+    | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
+    | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
+    | Reloc_getglobal kn, pos -> 
+	patch_int buff pos (slot_for_getglobal env kn)
+  in 
+  List.iter patch pl;
+  let vm_env = Array.map (slot_for_fv env) fv in 
+  let tc = tcode_of_code buff (length buff) in
+  eval_tcode tc vm_env
+
+and val_of_constr env c = 
+  let (_,fun_code,_ as ccfv) = 
+    try compile env c 
+    with e -> print_string "can not compile \n";Format.print_flush();raise e in
+  eval_to_patch env (to_memory ccfv)
+ 
+let set_transparent_const kn =
+  cst_opaque := Cpred.remove kn !cst_opaque;
+  List.iter (fun n -> (global_boxed()).(n) <- false) 
+    (Hashtbl.find_all boxed_tbl kn)
+
+let set_opaque_const kn =
+  cst_opaque := Cpred.add kn !cst_opaque;
+  List.iter (fun n -> (global_boxed()).(n) <- true) 
+    (Hashtbl.find_all boxed_tbl kn)
+
+
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
new file mode 100644
index 00000000..2640a4df
--- /dev/null
+++ b/kernel/csymtable.mli
@@ -0,0 +1,8 @@
+open Names
+open Term
+open Pre_env
+
+val val_of_constr : env -> constr -> values 
+
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index ac2c52cc..33d9959c 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,v 1.31.2.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: declarations.ml 8653 2006-03-22 09:41:17Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -14,40 +14,33 @@ open Names
 open Univ
 open Term
 open Sign
+open Mod_subst
 (*i*)
 
 (* This module defines the types of global declarations. This includes
    global constants/axioms and mutual inductive definitions *)
 
-(*s Constants (internal representation) (Definition/Axiom) *)
+type engagement = ImpredicativeSet
+
 
-type subst_internal = 
-  | Constr of constr 
-  | LazyConstr of substitution * constr
+(*s Constants (internal representation) (Definition/Axiom) *)
 
-type constr_substituted = subst_internal ref
+type constr_substituted = constr substituted
 
-let from_val c = ref (Constr c)
+let from_val = from_val
 
-let force cs = match !cs with
-    Constr c -> c
-  | LazyConstr (subst,c) -> 
-      let c' = subst_mps subst c in
-	cs := Constr c';
-	c'
+let force = force subst_mps 
 
-let subst_constr_subst subst cs = match !cs with
-    Constr c -> ref (LazyConstr (subst,c))
-  | LazyConstr (subst',c) -> 
-      let subst'' = join subst' subst in
-	ref (LazyConstr (subst'',c))
+let subst_constr_subst = subst_substituted
 
 type constant_body = {
-  const_hyps : section_context; (* New: younger hyp at top *)
-  const_body : constr_substituted option;
-  const_type : types;
-  const_constraints : constraints;
-  const_opaque : bool }
+    const_hyps : section_context; (* New: younger hyp at top *)
+    const_body : constr_substituted option;
+    const_type : types;  
+    const_body_code : Cemitcodes.to_patch_substituted;
+   (* const_type_code : Cemitcodes.to_patch; *)
+    const_constraints : constraints;
+    const_opaque : bool }
 
 (*s Inductive types (internal representation with redundant
     information). *)
@@ -82,72 +75,140 @@ let recarg_length p j =
 
 let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
 
-(* [mind_typename] is the name of the inductive; [mind_arity] is
-   the arity generalized over global parameters; [mind_lc] is the list
-   of types of constructors generalized over global parameters and
-   relative to the global context enriched with the arities of the
-   inductives *) 
+(**********************************************************************)
+(* Representation of mutual inductive types in the kernel             *)
+(*
+   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
+   ...
+   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
+*)
 
 type one_inductive_body = {
-  mind_typename : identifier;
-  mind_nparams : int;
-  mind_params_ctxt : rel_context;
-  mind_nrealargs : int;
-  mind_nf_arity : types;
-  mind_user_arity : types;
-  mind_sort : sorts;
-  mind_kelim : sorts_family list;
-  mind_consnames : identifier array;
-  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
-  mind_user_lc : types array;
-  mind_recargs : wf_paths;
- }
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity of [Ii] with parameters: [forall params, Ui] *)
+    mind_user_arity : types;
+
+ (* Names of the constructors: [cij] *)
+    mind_consnames : identifier array;
+
+ (* Types of the constructors with parameters: [forall params, Tij],
+    where the Ik are replaced by de Bruijn index in the context
+    I1:forall params, U1 ..  In:forall params, Un *)
+    mind_user_lc : types array;
+
+(* Derived datas *)
+
+ (* Head normalized arity so that the conclusion is a sort *)
+    mind_nf_arity : types;
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* Conclusion of the arity *)
+    mind_sort : sorts;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : types array;
+
+ (* Length of the signature of the constructors (with let, w/o params) *)
+    mind_consnrealdecls : int array;
+
+ (* Signature of recursive arguments in the constructors *)
+    mind_recargs : wf_paths;
+
+(* Datas for bytecode compilation *)
+
+ (* number of constant constructor *)
+    mind_nb_constant : int;
+
+ (* number of no constant constructor *)
+    mind_nb_args : int;
+
+    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+  }
 
 type mutual_inductive_body = {
-  mind_record : bool;
-  mind_finite : bool;
-  mind_ntypes : int;
-  mind_hyps : section_context;
-  mind_packets : one_inductive_body array;
-  mind_constraints : constraints;
-  mind_equiv : kernel_name option
- }
+
+  (* The component of the mutual inductive block *)
+    mind_packets : one_inductive_body array;
+
+  (* Whether the inductive type has been declared as a record *)
+    mind_record : bool;
+
+  (* Whether the type is inductive or coinductive *)
+    mind_finite : bool;
+
+  (* Number of types in the block *)
+    mind_ntypes : int;
+
+  (* Section hypotheses on which the block depends *)
+    mind_hyps : section_context;
+
+  (* Number of expected parameters *)
+    mind_nparams : int;
+
+  (* Number of recursively uniform (i.e. ordinary) parameters *)
+    mind_nparams_rec : int;
+
+  (* The context of parameters (includes let-in declaration) *)
+    mind_params_ctxt : rel_context;
+
+  (* Universes constraints enforced by the inductive declaration *)
+    mind_constraints : constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
 
 (* TODO: should be changed to non-coping after Term.subst_mps *)
-let subst_const_body sub cb = 
-  { const_body = option_app (subst_constr_subst sub) cb.const_body;
-    const_type = type_app (Term.subst_mps sub) cb.const_type;
+let subst_const_body sub cb = {
     const_hyps = (assert (cb.const_hyps=[]); []);
+    const_body = option_app (subst_constr_subst sub) cb.const_body;
+    const_type = type_app (subst_mps 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 } 
+
 let subst_mind_packet sub mbp = 
   { mind_consnames = mbp.mind_consnames;
+    mind_consnrealdecls = mbp.mind_consnrealdecls;
     mind_typename = mbp.mind_typename;
     mind_nf_lc = 
-      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_nf_lc;
-    mind_nf_arity = type_app (Term.subst_mps sub) mbp.mind_nf_arity;
+      array_smartmap (type_app (subst_mps sub)) mbp.mind_nf_lc;
+    mind_nf_arity = type_app (subst_mps sub) mbp.mind_nf_arity;
     mind_user_lc = 
-      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_user_lc;
-    mind_user_arity = type_app (Term.subst_mps sub) mbp.mind_user_arity;
+      array_smartmap (type_app (subst_mps sub)) mbp.mind_user_lc;
+    mind_user_arity = type_app (subst_mps sub) mbp.mind_user_arity;
     mind_sort = mbp.mind_sort;
     mind_nrealargs = mbp.mind_nrealargs;
     mind_kelim = mbp.mind_kelim;
-    mind_nparams = mbp.mind_nparams;
-    mind_params_ctxt = 
-      map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
-}
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); 
+    mind_nb_constant = mbp.mind_nb_constant;
+    mind_nb_args = mbp.mind_nb_args;
+    mind_reloc_tbl = mbp.mind_reloc_tbl }
+
 
 let subst_mind sub mib = 
   { mind_record = mib.mind_record ; 
     mind_finite = mib.mind_finite ;
     mind_ntypes = mib.mind_ntypes ;
     mind_hyps = (assert (mib.mind_hyps=[]); []) ;
+    mind_nparams = mib.mind_nparams;
+    mind_nparams_rec = mib.mind_nparams_rec;
+    mind_params_ctxt = 
+      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_app (subst_kn sub) mib.mind_equiv;
-}
+    mind_equiv = option_app (subst_kn sub) mib.mind_equiv }
 
 
 (*s Modules: signature component specifications, module types, and
@@ -171,7 +232,6 @@ and module_specification_body =
       msb_equiv : module_path option; 
       msb_constraints : constraints }
 
-
 type structure_elem_body = 
   | SEBconst of constant_body
   | SEBmind of mutual_inductive_body
@@ -193,3 +253,4 @@ and module_body =
       mod_type : module_type_body;
       mod_equiv : module_path option;
       mod_constraints : constraints }
+
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 6cff3936..7ad953e5 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -6,20 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli,v 1.33.2.3 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: declarations.mli 8653 2006-03-22 09:41:17Z herbelin $ i*)
 
 (*i*)
 open Names
 open Univ
 open Term
+open Cemitcodes
 open Sign
+open Mod_subst
 (*i*)
 
 (* This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
    inductive definitions, modules and module types *)
 
-(*s Constants (Definition/Axiom) *)
+type engagement = ImpredicativeSet
+
+(**********************************************************************)
+(*s Representation of constants (Definition/Axiom)                    *)
 
 type constr_substituted
 
@@ -27,16 +32,18 @@ val from_val : constr -> constr_substituted
 val force : constr_substituted -> constr
 
 type constant_body = {
-  const_hyps : section_context; (* New: younger hyp at top *)
-  const_body : constr_substituted option;
-  const_type : types;
-  const_constraints : constraints;
-  const_opaque : bool }
+    const_hyps : section_context; (* New: younger hyp at top *)
+    const_body : constr_substituted option;
+    const_type : types;  
+    const_body_code : to_patch_substituted;
+   (*i const_type_code : to_patch;i*)
+    const_constraints : constraints;
+    const_opaque : bool }
 
 val subst_const_body : substitution -> constant_body -> constant_body
 
-(*s Inductive types (internal representation with redundant
-    information). *)
+(**********************************************************************)
+(*s Representation of mutual inductive types in the kernel            *)
 
 type recarg = 
   | Norec 
@@ -55,41 +62,102 @@ val recarg_length : wf_paths -> int -> int
 
 val subst_wf_paths : substitution -> wf_paths -> wf_paths
 
-(* [mind_typename] is the name of the inductive; [mind_arity] is
-   the arity generalized over global parameters; [mind_lc] is the list
-   of types of constructors generalized over global parameters and
-   relative to the global context enriched with the arities of the
-   inductives *) 
+(*
+\begin{verbatim}
+   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
+   ...
+   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
+\end{verbatim}
+*)
 
 type one_inductive_body = {
-  mind_typename : identifier;
-  mind_nparams : int;
-  mind_params_ctxt : rel_context;
-  mind_nrealargs : int;
-  mind_nf_arity : types;
-  mind_user_arity : types;
-  mind_sort : sorts;
-  mind_kelim : sorts_family list;
-  mind_consnames : identifier array;
-  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
-  mind_user_lc : types array;
-  mind_recargs : wf_paths;
- }
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity of [Ii] with parameters: [forall params, Ui] *)
+    mind_user_arity : types;
+
+ (* Names of the constructors: [cij] *)
+    mind_consnames : identifier array;
+
+ (* Types of the constructors with parameters: [forall params, Tij],
+    where the Ik are replaced by de Bruijn index in the context
+    I1:forall params, U1 ..  In:forall params, Un *)
+    mind_user_lc : types array;
+
+(* Derived datas *)
+
+ (* Head normalized arity so that the conclusion is a sort *)
+    mind_nf_arity : types;
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* Conclusion of the arity *)
+    mind_sort : sorts;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : types array;
+
+ (* Length of the signature of the constructors (with let, w/o params) *)
+    mind_consnrealdecls : int array;
+
+ (* Signature of recursive arguments in the constructors *)
+    mind_recargs : wf_paths;
+
+(* Datas for bytecode compilation *)
+
+ (* number of constant constructor *)
+    mind_nb_constant : int;
+
+ (* number of no constant constructor *)
+    mind_nb_args : int;
+
+    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+  }
 
 type mutual_inductive_body = {
-  mind_record : bool;
-  mind_finite : bool;
-  mind_ntypes : int;
-  mind_hyps : section_context;
-  mind_packets : one_inductive_body array;
-  mind_constraints : constraints;
-  mind_equiv : kernel_name option;
- }
 
+  (* The component of the mutual inductive block *)
+    mind_packets : one_inductive_body array;
 
-val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
+  (* Whether the inductive type has been declared as a record *)
+    mind_record : bool;
+
+  (* Whether the type is inductive or coinductive *)
+    mind_finite : bool;
+
+  (* Number of types in the block *)
+    mind_ntypes : int;
 
+  (* Section hypotheses on which the block depends *)
+    mind_hyps : section_context;
+
+  (* Number of expected parameters *)
+    mind_nparams : int;
+
+  (* Number of recursively uniform (i.e. ordinary) parameters *)
+    mind_nparams_rec : int;
+
+  (* The context of parameters (includes let-in declaration) *)
+    mind_params_ctxt : rel_context;
+
+  (* Universes constraints enforced by the inductive declaration *)
+    mind_constraints : constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
+
+val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 
+(**********************************************************************)
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
diff --git a/kernel/entries.ml b/kernel/entries.ml
index a3d3d336..56b198c3 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,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: entries.ml 8647 2006-03-18 15:33:09Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -32,9 +32,9 @@ type local_entry =
 
 (* Assume the following definition in concrete syntax:
 \begin{verbatim}
-Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
 ...
-with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
 \end{verbatim}
 then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
@@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 *)
 
 type one_inductive_entry = {
-  mind_entry_params : (identifier * local_entry) list;
   mind_entry_typename : identifier;
   mind_entry_arity : constr;
   mind_entry_consnames : identifier list;
@@ -51,6 +50,7 @@ type one_inductive_entry = {
 type mutual_inductive_entry = {
   mind_entry_record : bool;
   mind_entry_finite : bool;
+  mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
 
@@ -59,7 +59,8 @@ type mutual_inductive_entry = {
 type definition_entry = {
   const_entry_body   : constr;
   const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_opaque : bool;
+  const_entry_boxed  : bool}
 
 type parameter_entry = types
 
@@ -84,8 +85,8 @@ and module_type_entry =
 and module_signature_entry = (label * specification_entry) list
 
 and with_declaration = 
-    With_Module of identifier * module_path
-  | With_Definition of identifier * constr
+    With_Module of identifier list * module_path
+  | With_Definition of identifier list * constr
 
 and module_expr = 
     MEident of module_path
diff --git a/kernel/entries.mli b/kernel/entries.mli
index e9bc420e..b9a95d44 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,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: entries.mli 8647 2006-03-18 15:33:09Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -32,9 +32,9 @@ type local_entry =
 
 (* Assume the following definition in concrete syntax:
 \begin{verbatim}
-Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
 ...
-with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
 \end{verbatim}
 then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
@@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 *)
 
 type one_inductive_entry = {
-  mind_entry_params : (identifier * local_entry) list;
   mind_entry_typename : identifier;
   mind_entry_arity : constr;
   mind_entry_consnames : identifier list;
@@ -51,15 +50,16 @@ type one_inductive_entry = {
 type mutual_inductive_entry = {
   mind_entry_record : bool;
   mind_entry_finite : bool;
+  mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
-
 (*s Constants (Definition/Axiom) *)
 
 type definition_entry = {
   const_entry_body   : constr;
   const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_opaque : bool;
+  const_entry_boxed  : bool }
 
 type parameter_entry = types
 
@@ -84,8 +84,8 @@ and module_type_entry =
 and module_signature_entry = (label * specification_entry) list
 
 and with_declaration = 
-    With_Module of identifier * module_path
-  | With_Definition of identifier * constr
+    With_Module of identifier list * module_path
+  | With_Definition of identifier list * constr
 
 and module_expr = 
     MEident of module_path
diff --git a/kernel/environ.ml b/kernel/environ.ml
index ec3c903d..77d77118 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml,v 1.89.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: environ.ml 7830 2006-01-10 22:45:28Z herbelin $ *)
 
 open Util
 open Names
@@ -14,49 +14,25 @@ open Sign
 open Univ
 open Term
 open Declarations
+open Pre_env
+open Csymtable
 
 (* The type of environments. *)
 
-type checksum = int
+type named_context_val = Pre_env.named_context_val
 
-type compilation_unit_name = dir_path * checksum
+type env = Pre_env.env
 
-type global = Constant | Inductive
+let pre_env env = env
 
-type engagement = ImpredicativeSet
+let empty_named_context_val = empty_named_context_val
 
-type globals = {
-  env_constants : constant_body KNmap.t;
-  env_inductives : mutual_inductive_body KNmap.t;
-  env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body KNmap.t }
-
-type stratification = {
-  env_universes : universes;
-  env_engagement : engagement option
-}
-
-type env = {
-  env_globals        : globals;
-  env_named_context  : named_context;
-  env_rel_context    : rel_context;
-  env_stratification : stratification }
-
-let empty_env = { 
-  env_globals = {
-    env_constants = KNmap.empty;
-    env_inductives = KNmap.empty;
-    env_modules = MPmap.empty;
-    env_modtypes = KNmap.empty };
-  env_named_context = empty_named_context;
-  env_rel_context = empty_rel_context;
-  env_stratification = {
-    env_universes = initial_universes;
-    env_engagement = None } }
+let empty_env = empty_env
 
 let engagement env = env.env_stratification.env_engagement
 let universes env = env.env_stratification.env_universes
 let named_context env = env.env_named_context
+let named_context_val env = env.env_named_context,env.env_named_vals
 let rel_context env = env.env_rel_context
 
 let empty_context env = 
@@ -75,68 +51,109 @@ let evaluable_rel n env =
   with Not_found -> 
     false
 
-let push_rel d env =
-  { env with
-      env_rel_context = add_rel_decl d env.env_rel_context }
+let nb_rel env = env.env_nb_rel
+
+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
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
-
+    
 let reset_rel_context env =
   { env with
-      env_rel_context = empty_rel_context }
+    env_rel_context = empty_rel_context;
+    env_rel_val = [];
+    env_nb_rel = 0 }
 
 let fold_rel_context f env ~init =
-  snd (Sign.fold_rel_context
-	 (fun d (env,e) -> (push_rel d env, f env d e))
-         (rel_context env) ~init:(reset_rel_context env,init))
-
+  let rec fold_right env =
+    match env.env_rel_context with
+    | [] -> init
+    | rd::rc ->
+	let env = 
+	  { env with
+	    env_rel_context = rc;
+	    env_rel_val = List.tl env.env_rel_val;
+	    env_nb_rel = env.env_nb_rel - 1 } in
+	f env rd (fold_right env) 
+  in fold_right env
 
 (* Named context *)
-let lookup_named id env =
-  Sign.lookup_named id env.env_named_context
 
-(* A local const is evaluable if it is defined and not opaque *)
-let evaluable_named id env =
-  try 
-    match lookup_named id env with
-        (_,Some _,_) -> true
-      | _ -> false
-  with Not_found -> 
-    false
+let named_context_of_val = fst
 
-let push_named d env =
-  { env with
-      env_named_context = Sign.add_named_decl d env.env_named_context }
+(* [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_app f body, f typ)) ctxt in
+  (ctxt,ctxtv)
 
-let reset_context env =
-  { env with
-      env_named_context = empty_named_context;
-      env_rel_context = empty_rel_context }
+let empty_named_context = empty_named_context 
 
-let reset_with_named_context ctxt env =
-  { env with
-      env_named_context = ctxt;
-      env_rel_context = empty_rel_context }
+let push_named = push_named
+let push_named_context_val = push_named_context_val
+
+let val_of_named_context ctxt =
+  List.fold_right push_named_context_val ctxt empty_named_context_val
+
+
+let lookup_named id env = Sign.lookup_named id env.env_named_context
+let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
+
+let eq_named_context_val c1 c2 =
+   c1 == c2 || named_context_of_val c1 = named_context_of_val c2
+
+(* A local const is evaluable if it is defined  *)
+
+let named_type id env =
+  let (_,_,t) = lookup_named id env in t
 
+let named_body id env =
+  let (_,b,_) = lookup_named id env in b
+
+let evaluable_named id env =
+  try 
+    match named_body id env with
+    |Some _      -> true
+    | _          -> false
+  with Not_found -> false
+      
+let reset_with_named_context (ctxt,ctxtv) env =
+  { env with
+    env_named_context = ctxt;
+    env_named_vals = ctxtv;
+    env_rel_context = empty_rel_context;
+    env_rel_val = [];
+    env_nb_rel = 0 }
+
+let reset_context = reset_with_named_context empty_named_context_val
+ 
 let fold_named_context f env ~init =
-  snd (Sign.fold_named_context
-	 (fun d (env,e) -> (push_named d env, f env d e))
-         (named_context env) ~init:(reset_context env,init))
+  let rec fold_right env =
+    match env.env_named_context with
+    | [] -> init
+    | d::ctxt ->
+	let env = 
+	  reset_with_named_context (ctxt,List.tl env.env_named_vals) env in
+	f env d (fold_right env) 
+  in fold_right env
 
 let fold_named_context_reverse f ~init env =
-  Sign.fold_named_context_reverse f ~init:init (named_context env) 
-
+  Sign.fold_named_context_reverse f ~init:init (named_context env)
+ 
 (* Global constants *)
-let lookup_constant kn env =
-  KNmap.find kn env.env_globals.env_constants
 
-let add_constant kn cb env =
-  let new_constants = KNmap.add kn cb env.env_globals.env_constants in
+let lookup_constant = lookup_constant
+
+let add_constant kn cs env =
+  let new_constants = 
+    Cmap.add kn (cs,ref None) env.env_globals.env_constants in
   let new_globals = 
     { env.env_globals with 
 	env_constants = new_constants } in 
@@ -168,8 +185,7 @@ let evaluable_constant cst env =
   with Not_found | NotEvaluableConst _ -> false
 
 (* Mutual Inductives *)
-let lookup_mind kn env =
-  KNmap.find kn env.env_globals.env_inductives
+let lookup_mind = lookup_mind
 
 let add_mind kn mib env =
   let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
@@ -253,7 +269,6 @@ let keep_hyps env needed =
     (named_context env)
     ~init:empty_named_context
 
-
 (* Modules *)
 
 let add_modtype ln mtb env = 
@@ -293,3 +308,61 @@ type unsafe_type_judgment = {
   utj_val : constr;
   utj_type : sorts }
 
+(*s Compilation of global declaration *)
+
+let compile_constant_body = Cbytegen.compile_constant_body  
+
+(*s Special functions for the refiner (logic.ml) *)
+
+let clear_hyps ids check (ctxt,vals) =
+  let ctxt,vals,rmv = 
+    List.fold_right2 (fun (id,_,_ as d) v (ctxt,vals,rmv) ->
+      if List.mem id ids then (ctxt,vals,id::rmv)
+      else begin
+	check rmv d;
+	(d::ctxt,v::vals,rmv)
+      end) ctxt vals ([],[],[])
+  in ((ctxt,vals),rmv)
+
+exception Hyp_not_found
+
+let rec apply_to_hyp (ctxt,vals) id f =
+  let rec aux rtail ctxt vals =
+    match ctxt, vals with
+    | (idc,c,ct as d)::ctxt, v::vals ->
+	if idc = id then
+	  (f ctxt d rtail)::ctxt, v::vals
+	else 
+	  let ctxt',vals' = aux (d::rtail) ctxt vals in
+	  d::ctxt', v::vals'
+    | [],[] -> raise Hyp_not_found
+    | _, _ -> assert false
+  in aux [] ctxt vals
+
+let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
+  let rec aux ctxt vals =
+    match ctxt,vals with
+    | (idc,c,ct as d)::ctxt, v::vals ->
+	if idc = id then
+	  let sign = ctxt,vals in
+	  push_named_context_val (f d sign) sign 
+	else 
+	  let (ctxt,vals as sign) = aux ctxt vals in
+	  push_named_context_val (g d sign) sign
+    | [],[] -> raise Hyp_not_found
+    | _,_ -> assert false
+  in aux ctxt vals
+
+let insert_after_hyp (ctxt,vals) id d check =
+  let rec aux ctxt vals =
+    match  ctxt, vals with
+    | (idc,c,ct)::ctxt', v::vals' ->
+	if idc = id then begin
+	  check ctxt; 
+	  push_named_context_val d (ctxt,vals) 
+	end else 
+	  let ctxt,vals = aux ctxt vals in
+	  d::ctxt, v::vals
+    | [],[] -> raise Hyp_not_found
+    | _, _ -> assert false
+  in aux ctxt vals
diff --git a/kernel/environ.mli b/kernel/environ.mli
index a2a66cb7..701159da 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,v 1.66.2.2 2005/01/21 16:41:49 herbelin Exp $ i*)
+(*i $Id: environ.mli 7640 2005-12-05 10:16:24Z gregoire $ i*)
 
 (*i*)
 open Names
@@ -22,21 +22,30 @@ open Sign
 
 (* Environments have the following components:
    - a context for de Bruijn variables
+   - a context for de Bruijn variables vm values
    - a context for section variables and goal assumptions
+   - a context for section variables and goal assumptions vm values 
    - a context for global constants and axioms
    - a context for inductive definitions
    - a set of universe constraints
    - a flag telling if Set is, can be, or cannot be set impredicative *)
 
+
+
+
 type env
+val pre_env : env -> Pre_env.env
+
+type named_context_val
+val eq_named_context_val : named_context_val -> named_context_val -> bool
 
 val empty_env : env
 
 val universes     : env -> Univ.universes
 val rel_context   : env -> rel_context
 val named_context : env -> named_context
+val named_context_val : env -> named_context_val
 
-type engagement = ImpredicativeSet
 
 val engagement    : env -> engagement option
 
@@ -45,6 +54,7 @@ val empty_context : env -> bool
 
 (************************************************************************)
 (*s Context of de Bruijn variables ([rel_context]) *)
+val nb_rel           : env -> int 
 val push_rel         : rel_declaration -> env -> env
 val push_rel_context :     rel_context -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
@@ -60,14 +70,35 @@ val fold_rel_context :
 
 (************************************************************************)
 (* Context of variables (section variables and goal assumptions) *)
+
+val named_context_of_val : named_context_val -> named_context
+val val_of_named_context : named_context -> named_context_val
+val empty_named_context_val : named_context_val
+
+
+(* [map_named_val f ctxt] apply [f] to the body and the type of
+   each declarations.
+   *** /!\ ***   [f t] should be convertible with t *)  
+val map_named_val : 
+   (constr -> constr) -> named_context_val -> named_context_val
+
 val push_named : named_declaration -> env -> env
+val push_named_context_val  : 
+    named_declaration -> named_context_val -> named_context_val
+
+
 
 (* Looks up in the context of local vars referred by names ([named_context]) *)
 (* raises [Not_found] if the identifier is not found *)
-val lookup_named    : variable -> env -> named_declaration
-val evaluable_named : variable -> env -> bool
 
+val lookup_named     : variable -> env -> named_declaration
+val lookup_named_val : variable -> named_context_val -> named_declaration
+val evaluable_named  : variable -> env -> bool
+val named_type : variable -> env -> types
+val named_body : variable -> env -> constr option
+ 
 (*s Recurrence on [named_context]: older declarations processed first *)
+
 val fold_named_context :
   (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
 
@@ -78,7 +109,7 @@ val fold_named_context_reverse :
 (* This forgets named and rel contexts *)
 val reset_context : env -> env
 (* This forgets rel context and sets a new named context *)
-val reset_with_named_context : named_context -> env -> env
+val reset_with_named_context : named_context_val -> env -> env
 
 (************************************************************************)
 (*s Global constants *)
@@ -87,6 +118,7 @@ val add_constant : constant -> constant_body -> env -> env
 
 (* Looks up in the context of global constant names *)
 (* raises [Not_found] if the required path is not found *)
+
 val lookup_constant    : constant -> env -> constant_body
 val evaluable_constant : constant -> env -> bool
 
@@ -153,7 +185,35 @@ type unsafe_type_judgment = {
   utj_type : sorts }
 
 
+(*s Compilation of global declaration *)
+
+val compile_constant_body : 
+    env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
+                                 (* opaque *) (* boxed *)
+
+(*s Functions for proofs/logic.ml *)
+val clear_hyps : 
+    variable list -> (variable list -> named_declaration -> unit) -> 
+      named_context_val -> named_context_val * variable list
+
+exception Hyp_not_found
 
+(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
+   return [tail::(f head (id,_,_) (rev tail))::head].
+   the value associated to id should not change *)
 
+val apply_to_hyp : named_context_val -> variable -> 
+  (named_context -> named_declaration -> named_context -> named_declaration) ->
+    named_context_val
 
+(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
+   [tail::(id,_,_)::head] and
+   return [(g tail)::(f (id,_,_))::head]. *)
+val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
+  (named_declaration -> named_context_val -> named_declaration) ->
+    (named_declaration -> named_context_val -> named_declaration) ->
+      named_context_val
 
+val insert_after_hyp : named_context_val -> variable ->
+  named_declaration -> 
+    (named_context -> unit) -> named_context_val
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 38db01fc..0a3f4578 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: esubst.ml,v 1.4.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: esubst.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Util
 
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 2fe981f7..39fbbede 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: esubst.mli,v 1.3.2.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: esubst.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (*s Compact representation of explicit relocations. \\
    [ELSHFT(l,n)] == lift of [n], then apply [lift l].
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 0b1d49f5..a3fc0db4 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml,v 1.59.2.4 2005/12/30 15:58:59 barras Exp $ *)
+(* $Id: indtypes.ml 8653 2006-03-22 09:41:17Z herbelin $ *)
 
 open Util
 open Names
@@ -26,14 +26,14 @@ let weaker_noccur_between env x nvars t =
   if noccur_between x nvars t then Some t
   else
    let t' = whd_betadeltaiota env t in
-   if noccur_between x nvars t then Some t'
+   if noccur_between x nvars t' then Some t'
    else None
 
 (************************************************************************)
 (* Various well-formedness check for inductive declarations            *)
 
+(* Errors related to inductive constructions *)
 type inductive_error =
-  (* These are errors related to inductive constructions in this module *)
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
   | NotConstructor of env * constr * constr
@@ -43,10 +43,6 @@ type inductive_error =
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
-  (* These are errors related to recursors building in Indrec *)
-  | NotAllowedCaseAnalysis of bool * sorts * inductive
-  | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
 
 exception InductiveError of inductive_error
 
@@ -141,7 +137,7 @@ let rec infos_and_sort env t =
 	let logic = not (is_info_type env varj) in
 	let small = Term.is_small varj.utj_type in
 	(logic,small) :: (infos_and_sort env1 c2)
-    | Cast (c,_) -> infos_and_sort env c
+    | Cast (c,_,_) -> infos_and_sort env c
     | _ -> []
 
 let small_unit constrsinfos =
@@ -175,19 +171,19 @@ let type_one_constructor env_ar_par params arsort c =
 
   (infos, full_cstr_type, cst2)
 
-let infer_constructor_packet env_ar params arsort vc =
+let infer_constructor_packet env_ar params arsort lc =
   let env_ar_par = push_rel_context params env_ar in
   let (constrsinfos,jlc,cst) = 
     List.fold_right
       (fun c (infosl,l,cst) ->
-	 let (infos,ct,cst') =
+	 let (infos,ct,cst') = 
 	   type_one_constructor env_ar_par params arsort c in
 	 (infos::infosl,ct::l, Constraint.union cst cst'))
-      vc
+      lc
       ([],[],Constraint.empty) in
-  let vc' = Array.of_list jlc in
+  let lc' = Array.of_list jlc in
   let issmall,isunit = small_unit constrsinfos in
-  (issmall,isunit,vc', cst)
+  (issmall,isunit,lc',cst)
 
 (* Type-check an inductive definition. Does not check positivity
    conditions. *)
@@ -196,16 +192,15 @@ let typecheck_inductive env mie =
   (* Check unicity of names *)
   mind_check_names mie;
   mind_check_arities env mie;
-  (* We first type params and arity of each inductive definition *)
+         (* Params are typed-checked here *)
+  let params = mie.mind_entry_params in
+  let env_params, params, cstp = infer_local_decls env params in
+  (* We first type arity of each inductive definition *)
   (* This allows to build the environment of arities and to share *)
   (* the set of constraints *)
   let cst, arities, rev_params_arity_list =
     List.fold_left
       (fun (cst,arities,l) ind ->
-         (* Params are typed-checked here *)
-	 let params = ind.mind_entry_params in
-	 let env_params, params, cst1 =
-           infer_local_decls env params in
          (* Arities (without params) are typed-checked here *)
 	 let arity, cst2 =
            infer_type env_params ind.mind_entry_arity in
@@ -215,10 +210,10 @@ let typecheck_inductive env mie =
 	    upper universe will be generated *)
 	 let id = ind.mind_entry_typename in
 	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
-	 Constraint.union cst (Constraint.union cst1 cst2),
+	 Constraint.union cst cst2,
 	 Sign.add_rel_decl (Name id, None, full_arity) arities,
          (params, id, full_arity, arity.utj_val)::l)
-      (Constraint.empty,empty_rel_context,[])
+      (cstp,empty_rel_context,[])
       mie.mind_entry_inds in
 
   let env_arities = push_rel_context arities env in
@@ -234,13 +229,13 @@ let typecheck_inductive env mie =
 	 let (issmall,isunit,lc',cst') =
 	   infer_constructor_packet env_arities params arsort lc in
 	 let consnames = ind.mind_entry_consnames in
-	 let ind' = (params,id,full_arity,consnames,issmall,isunit,lc')
+	 let ind' = (id,full_arity,consnames,issmall,isunit,lc')
 	 in
 	 (ind'::inds, Constraint.union cst cst'))
       mie.mind_entry_inds
       params_arity_list
       ([],cst) in
-  (env_arities, Array.of_list inds, cst)
+  (env_arities, params, Array.of_list inds, cst)
 
 (************************************************************************)
 (************************************************************************)
@@ -276,13 +271,18 @@ let explain_ind_err ntyp env0 nbpar c err =
 	raise (InductiveError 
 		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
 
+let failwith_non_pos n ntypes c =
+  for k = n to n + ntypes - 1 do
+    if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1)))
+  done
+
 let failwith_non_pos_vect n ntypes v =
-  for i = 0 to Array.length v - 1 do
-    for k = n to n + ntypes - 1 do
-      if not (noccurn k v.(i)) then raise (IllFormedInd (LocalNonPos (k-n+1)))
-    done
-  done;
-  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v"
+  Array.iter (failwith_non_pos n ntypes) v;
+  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur"
+
+let failwith_non_pos_list n ntypes l =
+  List.iter (failwith_non_pos n ntypes) l;
+  anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur"
 
 (* Check the inductive type is called with the expected parameters *)
 let check_correct_par (env,n,ntypes,_) hyps l largs =
@@ -303,6 +303,26 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
   if not (array_for_all (noccur_between n ntypes) largs') then 
     failwith_non_pos_vect n ntypes largs'
 
+(* Computes the maximum number of recursive parameters : 
+    the first parameters which are constant in recursive arguments 
+    n is the current depth, nmr is the maximum number of possible 
+    recursive parameters *)
+
+let compute_rec_par (env,n,_,_) hyps nmr largs = 
+if nmr = 0 then 0 else
+(* start from 0, hyps will be in reverse order *)
+  let (lpar,_) = list_chop nmr largs in
+  let rec find k index = 
+      function 
+	  ([],_) -> nmr
+	| (_,[]) -> assert false (* |hyps|>=nmr *)
+	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
+	| (p::lp,_::hyps) ->
+       ( match kind_of_term (whd_betadeltaiota env p) with
+	  | Rel w when w = index -> find (k+1) (index-1) (lp,hyps)
+          | _ -> k)
+  in find 0 (n-1) (lpar,List.rev hyps)
+
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
 let abstract_mind_lc env ntyps npars lc = 
@@ -326,9 +346,10 @@ let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
 
 let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let auxntyp = 1 in
+  let specif = lookup_mind_specif env mi in
   let env' =
     push_rel (Anonymous,None,
-              hnf_prod_applist env (type_of_inductive env mi) lpar) env in
+              hnf_prod_applist env (type_of_inductive specif) lpar) env in
   let ra_env' = 
     (Imbr mi,Rtree.mk_param 0) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
@@ -336,46 +357,50 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let newidx = n + auxntyp in
   (env', newidx, ntypes, ra_env')
 
+let array_min nmr a = if nmr = 0 then 0 else
+  Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
+
 (* The recursive function that checks positivity and builds the list
    of recursive arguments *)
 let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
-  let nparams = rel_context_length hyps in
+  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) 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 -> raise (IllFormedInd (LocalNonPos n));
+              None -> failwith_non_pos_list n ntypes [b]
             | Some b ->
-	        check_pos (ienv_push_var ienv (na, b, mk_norec)) d)
+	        check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
       | Rel k ->
-          let (ra,rarg) =
-            try List.nth ra_env (k-1)
-            with Failure _ | Invalid_argument _ -> (Norec,mk_norec) in
-          (match ra with
-              Mrec _ -> check_correct_par ienv hyps (k-n+1) largs
-            | _ ->
-                if not (List.for_all (noccur_between n ntypes) largs)
-	        then raise (IllFormedInd (LocalNonPos n)));
-          rarg
+           (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 mk_norec
-          else check_positive_imbr ienv (ind_kn, largs)
+          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 mk_norec
-	  else raise (IllFormedInd (LocalNonPos n))
+	  then (nmr,mk_norec)
+	  else failwith_non_pos_list n ntypes (x::largs)
 
-  (* accesses to the environment are not factorised, but does it worth
-     it? *)
-  and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) =
+  (* 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) =
     let (mib,mip) = lookup_mind_specif env mi in
-    let auxnpar = mip.mind_nparams in
+    let auxnpar = mib.mind_nparams_rec in
     let (lpar,auxlargs) =
       try list_chop auxnpar largs 
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
@@ -393,31 +418,34 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
     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 = 
+    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 c') 
+	  check_constructors ienv' false nmr c') 
 	auxlcvect
+    in
+    let irecargs = Array.map snd irecargs_nmr
+    and nmr' = array_min nmr irecargs_nmr
     in 
-    (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)
+    (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 c = 
-    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = 
+  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 recarg = check_pos ienv b in 
+            let nmr',recarg = check_pos ienv nmr b in 
             let ienv' = ienv_push_var ienv (na,b,mk_norec) in
-	    check_constr_rec ienv' (recarg::lrec) d
+	    check_constr_rec ienv' nmr' (recarg::lrec) d
 
 	| hd ->
 	    if check_head then
@@ -428,32 +456,39 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
 	    else
 	      if not (List.for_all (noccur_between n ntypes) largs)
               then raise (IllFormedInd (LocalNonPos n));
-	    List.rev lrec
-    in check_constr_rec ienv [] c
+	    (nmr,List.rev lrec)
+    in check_constr_rec ienv nmr [] c
   in
-  mk_paths (Mrec i)
-    (Array.map
+  let irecargs_nmr =
+     Array.map
       (fun c ->
-        let c = body_of_type c in
-        let sign, rawc = mind_extract_params nparams c in
-        let env' = push_rel_context sign env in
+        let _,rawc = mind_extract_params lparams c in
         try
-	  check_constructors ienv true rawc
+	  check_constructors ienv true nmr rawc
         with IllFormedInd err -> 
-	  explain_ind_err (ntypes-i) env nparams c err)
-      indlc)
+	  explain_ind_err (ntypes-i) env lparams c err)
+      indlc
+  in
+  let irecargs = Array.map snd irecargs_nmr
+  and nmr' = array_min nmr irecargs_nmr
+  in (nmr', mk_paths (Mrec i) irecargs)
 
-let check_positivity env_ar inds =
+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 check_one i (params,_,_,_,_,_,lc) =
-    let nparams = rel_context_length params in
+  let lparams = rel_context_length params in
+  let nmr = rel_context_nhyps params in
+  let check_one i (_,_,_,_,_,lc) =
     let ra_env =
-      list_tabulate (fun _ -> (Norec,mk_norec)) nparams @ lra_ind in
-    let ienv = (env_ar, 1+nparams, ntypes, ra_env) in
-    check_positivity_one ienv params i lc in
-  Rtree.mk_rec (Array.mapi check_one inds)
+      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 
+  in
+  let irecargs_nmr = Array.mapi check_one inds in 
+  let irecargs = Array.map snd irecargs_nmr
+  and nmr' = array_min nmr irecargs_nmr
+  in (nmr',Rtree.mk_rec irecargs)
 
 
 (************************************************************************)
@@ -480,67 +515,77 @@ let allowed_sorts env issmall isunit = function
       if issmall then all_sorts
       else impredicative_sorts
   | Prop Null -> 
-(* Added InType which is derivable :when the type is unit and small *)
-(* unit+small types have all elimination 
-   In predicative system, the 
-   other inductive definitions have only Prop elimination.
-   In impredicative system, large unit type have also Set elimination
-*)   if isunit then 
-	if issmall then all_sorts
-	else if Environ.engagement env = None 
-        then logical_sorts else impredicative_sorts
+(* 29/1/02: added InType which is derivable when the type is unit and small *)
+      if isunit then all_sorts
       else logical_sorts
 
-let build_inductive env env_ar record finite inds recargs cst =
+let fold_inductive_blocks f =
+  Array.fold_left (fun acc (_,ar,_,_,_,lc) -> f (Array.fold_left f acc lc) ar)
+
+let used_section_variables env inds =
+  let ids = fold_inductive_blocks
+    (fun l c -> Idset.union (Environ.global_vars_set env c) l)
+      Idset.empty inds in
+  keep_hyps env ids
+
+let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
   let ntypes = Array.length inds in
   (* Compute the set of used section variables *)
-  let ids = 
-    Array.fold_left 
-      (fun acc (_,_,ar,_,_,_,lc) -> 
-	 Idset.union (Environ.global_vars_set env (body_of_type ar))
-	   (Array.fold_left
-	      (fun acc c ->
-                Idset.union (global_vars_set env (body_of_type c)) acc)
-	      acc
-	      lc))
-      Idset.empty inds in
-  let hyps = keep_hyps env ids in
+  let hyps =  used_section_variables env inds in
+  let nparamargs = rel_context_nhyps params in
   (* Check one inductive *)
-  let build_one_packet (params,id,ar,cnames,issmall,isunit,lc) recarg =
+  let build_one_packet (id,ar,cnames,issmall,isunit,lc) recarg =
     (* Arity in normal form *)
-    let nparamargs = rel_context_nhyps params in
     let (ar_sign,ar_sort) = dest_arity env ar in
-    let nf_ar =
-      if isArity (body_of_type ar) then ar
-      else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in
+    let nf_ar = if isArity ar then ar else mkArity (ar_sign,ar_sort) in
     (* Type of constructors in normal form *)
     let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
-    let nf_lc =
-      array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in
+    let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
     let nf_lc = if nf_lc = lc then lc else nf_lc in
+    let consnrealargs =
+      Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
+	splayed_lc in
     (* Elimination sorts *)
     let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in
     let kelim = allowed_sorts env issmall isunit ar_sort 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) *)
+    in 
+    let rtbl = Array.init (List.length cnames) transf in
     (* Build the inductive packet *)
     { mind_typename = id;
-      mind_nparams = nparamargs;
-      mind_params_ctxt = params;
       mind_user_arity  = ar;
       mind_nf_arity = nf_ar;
       mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
       mind_sort = ar_sort;
       mind_kelim = kelim;
       mind_consnames = Array.of_list cnames;
+      mind_consnrealdecls = consnrealargs;
       mind_user_lc = lc;
       mind_nf_lc = nf_lc;
-      mind_recargs = recarg;
+      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 = record;
+  { mind_record = isrecord;
     mind_ntypes = ntypes;
-    mind_finite = finite;
+    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;
@@ -551,10 +596,9 @@ let build_inductive env env_ar record finite inds recargs cst =
 
 let check_inductive env mie =
   (* First type-check the inductive definition *)
-  let (env_arities, inds, cst) = typecheck_inductive env mie in
+  let (env_ar, params, inds, cst) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
-  let recargs = check_positivity env_arities inds in
+  let (nmr,recargs) = check_positivity env_ar params inds in
   (* Build the inductive packets *)
-  build_inductive env env_arities mie.mind_entry_record mie.mind_entry_finite 
-    inds 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 f5e6d047..67d11f56 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,v 1.23.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+(*i $Id: indtypes.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -22,8 +22,8 @@ open Typeops
 (*s The different kinds of errors that may result of a malformed inductive
   definition. *)
 
+(* Errors related to inductive constructions *)
 type inductive_error =
-  (* These are errors related to inductive constructions in this module *)
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
   | NotConstructor of env * constr * constr
@@ -33,10 +33,6 @@ type inductive_error =
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
-  (* These are errors related to recursors building in Indrec *)
-  | NotAllowedCaseAnalysis of bool * sorts * inductive
-  | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
 
 exception InductiveError of inductive_error
 
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 07e9b8ea..736f4da1 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml,v 1.74.2.2 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: inductive.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
 
 open Util
 open Names
@@ -18,6 +18,8 @@ open Environ
 open Reduction
 open Type_errors
 
+type mind_specif = mutual_inductive_body * one_inductive_body
+
 (* raise Not_found if not an inductive type *)
 let lookup_mind_specif env (kn,tyi) =
   let mib = Environ.lookup_mind kn env in
@@ -57,13 +59,10 @@ let ind_subst mind mib =
 (* Instantiate inductives in constructor type *)
 let constructor_instantiate mind mib c =
   let s = ind_subst mind mib in
-  type_app (substl s) c
+  substl s c
 
-(* Instantiate the parameters of the inductive type *)
-(* TODO: verify the arg of LetIn correspond to the value in the
-   signature ? *)
-let instantiate_params t args sign =
-  let fail () =
+let instantiate_params full t args sign =
+  let fail () = 
     anomaly "instantiate_params: type, ctxt and args mismatch" in
   let (rem_args, subs, ty) =
     Sign.fold_rel_context
@@ -71,38 +70,134 @@ let instantiate_params t args sign =
         match (copt, largs, kind_of_term ty) with
           | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
           | (Some b,_,LetIn(_,_,_,t))    -> (largs, (substl subs b)::subs, t)
-	  | _                            -> fail())
+	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
+	  | _                       -> fail ())
       sign
       ~init:(args,[],t) 
   in
   if rem_args <> [] then fail();
-  type_app (substl subs) ty
+  substl subs ty
+
+let instantiate_partial_params = instantiate_params false
 
-let full_inductive_instantiate mip params t =
-  instantiate_params t params mip.mind_params_ctxt
+let full_inductive_instantiate mib params t =
+  instantiate_params true t params mib.mind_params_ctxt
 
-let full_constructor_instantiate (((mind,_),mib,mip),params) =
+let full_constructor_instantiate (((mind,_),mib,_),params) =
   let inst_ind = constructor_instantiate mind mib in
   (fun t ->
-    instantiate_params (inst_ind t) params mip.mind_params_ctxt)
+    instantiate_params true (inst_ind t) params mib.mind_params_ctxt)
 
 (************************************************************************)
 (************************************************************************)
 
 (* Functions to build standard types related to inductive *)
 
+(* For each inductive type of a block that is of level u_i, we have
+   the constraints that u_i >= v_i where v_i is the type level of the
+   types of the constructors of this inductive type. Each v_i depends
+   of some of the u_i and of an extra (maybe non variable) universe,
+   say w_i. Typically, for three inductive types, we could have
+
+   u1,u2,u3,w1 <= u1
+   u1       w2 <= u2
+      u2,u3,w3 <= u3
+
+   From this system of inequations, we shall deduce
+
+   w1,w2,w3 <= u1
+   w1,w2 <= u2
+   w1,w2,w3 <= u3
+*)   
+
+let number_of_inductives mib = Array.length mib.mind_packets
+let number_of_constructors mip = Array.length mip.mind_consnames
+
+(* 
+Computing the actual sort of an applied or partially applied inductive type:
+
+I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a)
+uniformargs : utyps 
+otherargs : otyps
+I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj
+s'_k = max(..s_kj..)
+merge(..s'_k..) = ..s''_k..
+--------------------------------------------------------------------
+Gamma |- I_i uniformargs otherargs : phi(s''_i)
+
+where
+
+- if p=0, phi() = Prop
+- if p=1, phi(s) = s
+- if p<>1, phi(s) = sup(Set,s)
+
+Remark: Set (predicative) is encoded as Type(0)
+*)
+
+let find_constraint levels level_bounds i nci =
+  if nci = 0 then mk_Prop
+  else
+    let level_bounds' = solve_constraints_system levels level_bounds in
+    let level = level_bounds'.(i) in
+    if nci = 1 & is_empty_universe level then mk_Prop
+    else if Univ.is_base level then mk_Set else Type level
+
+let find_inductive_level env (mib,mip) (_,i) levels level_bounds =
+  find_constraint levels level_bounds i (number_of_constructors mip)
+
+let set_inductive_level env s t = 
+  let sign,s' = dest_prod_assum env t in
+  if family_of_sort s <> family_of_sort (destSort s') then
+    (* This induces reductions if user_arity <> nf_arity *)
+    mkArity (sign,s)
+  else
+    t
+
+let constructor_instances env (mib,mip) (_,i) args =
+  let nargs = Array.length args in
+  let args = Array.to_list args in
+  let uargs = 
+    if nargs > mib.mind_nparams_rec then
+      fst (list_chop mib.mind_nparams_rec args)
+    else args in
+  let arities =
+    Array.map (fun mip -> destArity mip.mind_nf_arity) mib.mind_packets in
+  (* Compute the minimal type *)
+  let levels = Array.init 
+    (number_of_inductives mib) (fun _ -> fresh_local_univ ()) in
+  let arities = list_tabulate (fun i -> 
+    let ctx,s = arities.(i) in
+    let s = match s with Type _ -> Type (levels.(i)) | s -> s in
+    (Name mib.mind_packets.(i).mind_typename,None,mkArity (ctx,s)))
+    (number_of_inductives mib) in
+             (* Remark: all arities are closed hence no need for lift *)
+  let env_ar = push_rel_context (List.rev arities) env in
+  let uargs = List.map (lift (number_of_inductives mib)) uargs in
+  let lc =
+    Array.map (fun mip ->
+        Array.map (fun c -> 
+	    instantiate_partial_params c uargs mib.mind_params_ctxt)
+          mip.mind_nf_lc)
+      mib.mind_packets in
+  env_ar, lc, levels
+
+let is_small_inductive (mip,mib) = is_small (snd (destArity mib.mind_nf_arity))
+
+let max_inductive_sort v =
+  let v = Array.map (function
+    | Type u -> u
+    | _ -> anomaly "Only type levels when computing the minimal sort of an inductive type") v in
+  Univ.sup_array v
+
 (* Type of an inductive type *)
 
-let type_of_inductive env i =
-  let (_,mip) = lookup_mind_specif env i in
-  mip.mind_user_arity
+let type_of_inductive (_,mip) = mip.mind_user_arity
 
 (************************************************************************)
 (* Type of a constructor *)
 
-let type_of_constructor env cstr =
+let type_of_constructor cstr (mib,mip) =
   let ind = inductive_of_constructor cstr in
-  let (mib,mip) = lookup_mind_specif env ind in
   let specif = mip.mind_user_lc in
   let i = index_of_constructor cstr in
   let nconstr = Array.length mip.mind_consnames in
@@ -113,8 +208,8 @@ let arities_of_specif kn (mib,mip) =
   let specif = mip.mind_nf_lc in
   Array.map (constructor_instantiate kn mib) specif
 
-let arities_of_constructors env ind = 
-  arities_of_specif (fst ind) (lookup_mind_specif env ind)
+let arities_of_constructors ind specif = 
+  arities_of_specif (fst ind) specif
 
 
 
@@ -149,23 +244,28 @@ let local_rels ctxt =
   rels
 
 (* Get type of inductive, with parameters instantiated *)
-let get_arity mip params =
+let get_arity mib mip params =
   let arity = mip.mind_nf_arity in
-  destArity (full_inductive_instantiate mip params arity)
+  destArity (full_inductive_instantiate mib params arity)
 
-let build_dependent_inductive ind mip params =
-  let arsign,_ = get_arity mip params in
+let rel_list n m = 
+  let rec reln l p = 
+    if p>m then l else reln (mkRel(n+p)::l) (p+1)
+  in 
+  reln [] 1
+
+let build_dependent_inductive ind mib mip params =
   let nrealargs = mip.mind_nrealargs in
   applist 
-    (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign))
+    (mkInd ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs))
 
 
 (* This exception is local *)
 exception LocalArity of (constr * constr * arity_error) option
 
-let is_correct_arity env c pj ind mip params = 
+let is_correct_arity env c pj ind mib mip params = 
   let kelim = mip.mind_kelim in
-  let arsign,s = get_arity mip params in
+  let arsign,s = get_arity mib mip params in
   let nodep_ar = it_mkProd_or_LetIn (mkSort s) arsign in
   let rec srec env pt t u =
     let pt' = whd_betadeltaiota env pt in
@@ -181,7 +281,9 @@ let is_correct_arity env c pj ind mip params =
           let ksort = match kind_of_term k with
             | Sort s -> family_of_sort s 
 	    | _ -> raise (LocalArity None) in
-	  let dep_ind = build_dependent_inductive ind mip params in
+
+	  let dep_ind = build_dependent_inductive ind mib mip params
+	  in 
           let univ =
             try conv env a1 dep_ind
             with NotConvertible -> raise (LocalArity None) in
@@ -225,7 +327,7 @@ let build_branches_type ind mib mip params dep p =
     let (args,ccl) = decompose_prod_assum typi in
     let nargs = rel_context_length args in
     let (_,allargs) = decompose_app ccl in
-    let (lparams,vargs) = list_chop mip.mind_nparams allargs in
+    let (lparams,vargs) = list_chop mib.mind_nparams allargs in
     let cargs =
       if dep then
         let cstr = ith_constructor_of_inductive ind (i+1) in
@@ -245,10 +347,10 @@ let build_case_type dep p c realargs =
 
 let type_case_branches env (ind,largs) pj c =
   let (mib,mip) = lookup_mind_specif env ind in 
-  let nparams = mip.mind_nparams in
+  let nparams = mib.mind_nparams in
   let (params,realargs) = list_chop nparams largs in
   let p = pj.uj_val in
-  let (dep,univ) = is_correct_arity env c pj ind mip params in
+  let (dep,univ) = is_correct_arity env c pj ind mib mip params in
   let lc = build_branches_type ind mib mip params dep p in
   let ty = build_case_type dep p c realargs in
   (lc, ty, univ)
@@ -257,11 +359,22 @@ let type_case_branches env (ind,largs) pj c =
 (************************************************************************)
 (* Checking the case annotation is relevent *)
 
+let rec inductive_kn_equiv env kn1 kn2 =
+  match (lookup_mind kn1 env).mind_equiv with
+    | Some kn1' -> inductive_kn_equiv env kn2 kn1'
+    | None -> match (lookup_mind kn2 env).mind_equiv with
+        | Some kn2' -> inductive_kn_equiv env kn2' kn1
+	| None -> false
+
+let inductive_equiv env (kn1,i1) (kn2,i2) =
+  i1=i2 & inductive_kn_equiv env kn1 kn2
+
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
     (indsp <> ci.ci_ind) or
-    (mip.mind_nparams <> ci.ci_npar)
+    (mib.mind_nparams <> ci.ci_npar) or
+    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -416,7 +529,7 @@ let inductive_of_fix env recarg body =
    subterm_specif env c ind 
 
    subterm_specif should test if [c] (building objects of inductive
-   type [ind], not necassarily the same as that of the recursive
+   type [ind], not necessarily the same as that of the recursive
    argument) is a subterm of the recursive argument of the fixpoint we
    are checking and fails with Not_found if not. In case it is, it
    should send its recursive specification (i.e. on which arguments we
@@ -584,7 +697,6 @@ let check_one_fix renv recpos def =
       | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
           List.for_all (check_rec_call renv) l &&
           array_for_all (check_rec_call renv) typarray && 
-	  let nbfix = Array.length typarray in
           let decrArg = recindxs.(i) in
           let renv' = push_fix_renv renv recdef in 
           if (List.length l < (decrArg+1)) then
@@ -604,7 +716,7 @@ let check_one_fix renv recpos def =
                 bodies in
             array_for_all (fun b -> b) ok_vect
 
-      | Const kn as c -> 
+      | Const kn -> 
           (try List.for_all (check_rec_call renv) l
            with (FixGuardError _ ) as e ->
              if evaluable_constant kn renv.env then 
@@ -614,7 +726,7 @@ let check_one_fix renv recpos def =
 
       (* The cases below simply check recursively the condition on the
          subterms *)
-      | Cast (a,b) -> 
+      | Cast (a,_, b) -> 
           List.for_all (check_rec_call renv) (a::b::l)
 
       | Lambda (x,a,b) ->
@@ -668,8 +780,8 @@ 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 raise_err i err =
-    error_ill_formed_rec_body fixenv err names i in
+  let raise_err env i err =
+    error_ill_formed_rec_body env err names i in
   (* Check the i-th definition with recarg k *)
   let find_ind i k def = 
     if k < 0 then anomaly "negative recarg position";
@@ -684,18 +796,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) = 
                   try find_inductive env a 
-                  with Not_found -> raise_err i RecursionNotOnInductiveType in
+                  with Not_found ->
+		    raise_err env i (RecursionNotOnInductiveType a) in
                 (mind, (env', b))
 	      else check_occur env' (n+1) b
             else anomaly "check_one_fix: Bad occurrence of recursive call"
-        | _ -> raise_err i NotEnoughAbstractionInFixBody in
+        | _ -> raise_err env i NotEnoughAbstractionInFixBody in
     check_occur fixenv 1 def in
   (* Do it on every fixpoint *)
   let rv = array_map2_i find_ind nvect bodies in
   (Array.map fst rv, Array.map snd rv)
 
 
-let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
+let 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
@@ -760,7 +873,7 @@ let check_one_cofix env nbfix def deftype =
             let lra =vlra.(i-1) in 
             let mI = inductive_of_constructor cstr_kn in
 	    let (mib,mip) = lookup_mind_specif env mI in
-            let realargs = list_skipn mip.mind_nparams args in
+            let realargs = list_skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
               | (t::lr), (rar::lrar) -> 
                   if rar = mk_norec then
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 04345621..e60f909e 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,v 1.57.8.2 2005/01/21 16:41:49 herbelin Exp $ i*)
+(*i $Id: inductive.mli 8673 2006-03-29 21:21:52Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -28,24 +28,24 @@ val find_rectype     : env -> types -> inductive * constr list
 val find_inductive   : env -> types -> inductive * constr list
 val find_coinductive : env -> types -> inductive * constr list
 
+type mind_specif = mutual_inductive_body * one_inductive_body
+
 (*s Fetching information in the environment about an inductive type.
     Raises [Not_found] if the inductive type is not found. *)
-val lookup_mind_specif :
-  env -> inductive -> mutual_inductive_body * one_inductive_body
+val lookup_mind_specif : env -> inductive -> mind_specif
 
 (*s Functions to build standard types related to inductive *)
 
-val type_of_inductive    : env -> inductive -> types
+val type_of_inductive : mind_specif -> types
 
 (* Return type as quoted by the user *)
-val type_of_constructor  : env -> constructor -> types
+val type_of_constructor : constructor -> mind_specif -> types
 
 (* Return constructor types in normal form *)
-val arities_of_constructors : env -> inductive -> types array
+val arities_of_constructors : inductive -> mind_specif -> types array
 
 (* Transforms inductive specification into types (in nf) *)
-val arities_of_specif : mutual_inductive -> 
-  mutual_inductive_body * one_inductive_body -> types array 
+val arities_of_specif : mutual_inductive -> mind_specif -> types array 
 
 (* [type_case_branches env (I,args) (p:A) c] computes useful types
    about the following Cases expression:
@@ -69,3 +69,17 @@ val scrape_mind : env -> mutual_inductive -> mutual_inductive
 (*s Guard conditions for fix and cofix-points. *)
 val check_fix : env -> fixpoint -> unit
 val check_cofix : env -> cofixpoint -> unit
+
+(*s Support for sort-polymorphic inductive types *)
+
+val constructor_instances : env -> mind_specif -> inductive -> 
+  constr array -> env * types array array * universe array
+
+val set_inductive_level : env -> sorts -> types -> types
+
+val find_inductive_level : env -> mind_specif -> inductive -> 
+  universe array -> universe array -> sorts
+
+val is_small_inductive : mind_specif -> bool
+
+val max_inductive_sort : sorts array -> universe
diff --git a/kernel/make-opcodes b/kernel/make-opcodes
new file mode 100644
index 00000000..c8f573c6
--- /dev/null
+++ b/kernel/make-opcodes
@@ -0,0 +1,2 @@
+$1=="enum" {n=0; next; }
+           {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
new file mode 100644
index 00000000..6d2064bf
--- /dev/null
+++ b/kernel/mod_subst.ml
@@ -0,0 +1,260 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: mod_subst.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Term
+
+(* WARNING: not every constant in the associative list domain used to exist
+   in the environment. This allows a simple implementation of the join
+   operation. However, iterating over the associative list becomes a non-sense
+*)
+type resolver = (constant * constr option) list
+
+let make_resolver resolve = resolve
+
+let apply_opt_resolver resolve kn =
+ match resolve with
+    None -> None
+  | Some resolve ->
+     try List.assoc kn resolve with Not_found -> assert false
+
+type substitution_domain = MSI of mod_self_id | MBI of mod_bound_id
+
+let string_of_subst_domain = function
+   MSI msid -> debug_string_of_msid msid
+ | MBI mbid -> debug_string_of_mbid mbid
+
+module Umap = Map.Make(struct 
+			 type t = substitution_domain
+			 let compare = Pervasives.compare
+		       end)
+
+type substitution = (module_path * resolver option) Umap.t
+
+let empty_subst = Umap.empty
+
+let add_msid msid mp =
+  Umap.add (MSI msid) (mp,None)
+let add_mbid mbid mp resolve =
+  Umap.add (MBI mbid) (mp,resolve)
+
+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 list_contents sub = 
+  let one_pair uid (mp,_) l =
+    (string_of_subst_domain uid, string_of_mp mp)::l
+  in
+    Umap.fold one_pair sub []
+
+let debug_string_of_subst sub = 
+  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
+    "{" ^ String.concat "; " l ^ "}"
+
+let debug_pr_subst sub = 
+  let l = list_contents sub in
+  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
+  in
+    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
+
+let subst_mp0 sub mp = (* 's like subst *)
+ let rec aux mp =
+  match mp with
+    | MPself sid -> 
+        let mp',resolve = Umap.find (MSI sid) sub in
+         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
+    | _ -> raise Not_found
+ in
+  try Some (aux mp) with Not_found -> None
+
+let subst_mp sub mp =
+ match subst_mp0 sub mp with
+    None -> mp
+  | Some (mp',_) -> mp'
+
+
+let subst_kn0 sub kn =
+ let mp,dir,l = repr_kn kn in
+  match subst_mp0 sub mp with
+     Some (mp',_) ->
+      Some (make_kn mp' dir l)
+   | None -> None
+
+let subst_kn sub kn =
+ match subst_kn0 sub kn with
+    None -> kn
+  | Some kn' -> kn'
+
+let subst_con sub con =
+ let mp,dir,l = repr_con con in
+  match subst_mp0 sub mp with
+     None -> con,mkConst con
+   | Some (mp',resolve) ->
+      let con' = make_con mp' dir l in
+       match apply_opt_resolver resolve con with
+          None -> con',mkConst con'
+        | Some t -> con',t
+
+(* Here the semantics is completely unclear.
+   What does "Hint Unfold t" means when "t" is a parameter?
+   Does the user mean "Unfold X.t" or does she mean "Unfold y"
+   where X.t is later on instantiated with y? I choose the first
+   interpretation (i.e. an evaluable reference is never expanded). *)
+let subst_evaluable_reference subst = function
+  | EvalVarRef id -> EvalVarRef id
+  | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
+
+(* 
+This should be rewritten to prevent duplication of constr's when not
+necessary.
+For now, it uses map_constr and is rather ineffective
+*)
+
+let rec map_kn f f' c = 
+  let func = map_kn f f' in
+    match kind_of_term c with
+      | Const kn -> f' kn
+      | Ind (kn,i) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	      mkInd (kn',i))
+      | Construct ((kn,i),j) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	      mkConstruct ((kn',i),j))
+      | Case (ci,p,c,l) ->
+	  let ci' =
+           { ci with
+              ci_ind =
+               let (kn,i) = ci.ci_ind in
+                match f kn with None -> ci.ci_ind | Some kn' -> kn',i } in
+	  mkCase (ci', func p, func c, array_smartmap func l) 
+      | _ -> map_constr func c
+
+let subst_mps sub = 
+  map_kn (subst_kn0 sub) (fun con -> snd (subst_con sub con))
+
+let rec replace_mp_in_mp mpfrom mpto mp =
+  match mp with
+    | _ when mp = mpfrom -> mpto
+    | MPdot (mp1,l) -> 
+	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
+	  if mp1==mp1' then mp
+	  else MPdot (mp1',l)
+    | _ -> mp
+
+let replace_mp_in_con mpfrom mpto kn =
+ let mp,dir,l = repr_con kn in
+  let mp'' = replace_mp_in_mp mpfrom mpto mp in
+    if mp==mp'' then kn
+    else make_con mp'' dir l
+
+exception BothSubstitutionsAreIdentitySubstitutions
+exception ChangeDomain of resolver
+
+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 ->
+        Some
+         ((List.map
+            (fun (kn,topt) ->
+              let key' =
+               match key with
+                  MSI msid -> MPself msid
+                | MBI mbid -> MPbound mbid in
+              (* let's replace mp with key in kn *)
+              let kn' = replace_mp_in_con mp key' kn in
+               kn',topt)) res)
+   in
+    mp',resolve'' in
+  let subst = Umap.mapi (apply_subst subst2) subst1 in
+  Umap.fold Umap.add subst2 subst
+
+let rec occur_in_path uid path =
+ match uid,path with
+  | MSI sid,MPself sid' -> sid = sid'
+  | MBI bid,MPbound bid' -> bid = bid'
+  | _,MPdot (mp1,_) -> occur_in_path uid mp1
+  | _ -> false
+    
+let occur_uid uid sub = 
+  let check_one uid' (mp,_) =
+    if uid = uid' || occur_in_path uid mp then raise Exit
+  in
+    try 
+      Umap.iter check_one sub;
+      false
+    with Exit -> true
+
+let occur_msid uid = occur_uid (MSI uid)
+let occur_mbid uid = occur_uid (MBI uid)
+    
+type 'a lazy_subst =
+  | LSval of 'a
+  | LSlazy of substitution * 'a
+	
+type 'a substituted = 'a lazy_subst ref
+      
+let from_val a = ref (LSval a)
+    
+let force fsubst r = 
+  match !r with
+  | LSval a -> a
+  | LSlazy(s,a) -> 
+      let a' = fsubst s a in
+      r := LSval a';
+      a' 
+
+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))
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
new file mode 100644
index 00000000..a7915a24
--- /dev/null
+++ b/kernel/mod_subst.mli
@@ -0,0 +1,80 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: mod_subst.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+
+(*s [Mod_subst] *)
+
+open Names
+open Term
+
+type resolver
+type substitution
+
+val make_resolver :  (constant * constr option) list -> resolver
+
+val empty_subst : substitution
+
+val add_msid : 
+  mod_self_id -> module_path -> substitution -> substitution
+val add_mbid : 
+  mod_bound_id -> module_path -> resolver option -> substitution -> substitution
+
+val map_msid :
+  mod_self_id -> module_path -> substitution
+val map_mbid :
+  mod_bound_id -> module_path -> resolver option -> substitution
+
+(* sequential composition: 
+   [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
+*)
+val join : substitution -> substitution -> substitution
+
+type 'a substituted
+val from_val : 'a -> 'a substituted
+val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a
+val subst_substituted : substitution -> 'a substituted -> 'a substituted
+
+(*i debugging *)
+val debug_string_of_subst : substitution -> string
+val debug_pr_subst : substitution -> Pp.std_ppcmds
+(*i*)
+
+(* [subst_mp sub mp] guarantees that whenever the result of the
+   substitution is structutally equal [mp], it is equal by pointers 
+   as well [==] *) 
+
+val subst_mp : 
+  substitution -> module_path -> module_path
+
+val subst_kn :
+  substitution -> kernel_name -> kernel_name
+
+val subst_con :
+  substitution -> constant -> constant * constr
+
+(* Here the semantics is completely unclear.
+   What does "Hint Unfold t" means when "t" is a parameter?
+   Does the user mean "Unfold X.t" or does she mean "Unfold y"
+   where X.t is later on instantiated with y? I choose the first
+   interpretation (i.e. an evaluable reference is never expanded). *)
+val subst_evaluable_reference :
+  substitution -> evaluable_global_reference -> evaluable_global_reference
+
+(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
+val replace_mp_in_con : module_path -> module_path -> constant -> constant
+
+(* [subst_mps sub c] performs the substitution [sub] on all kernel
+   names appearing in [c] *)
+val subst_mps : substitution -> constr -> constr
+
+(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
+   on either side *)
+
+val occur_msid : mod_self_id -> substitution -> bool
+val occur_mbid : mod_bound_id -> substitution -> bool
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 5e8c7001..a8aff184 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,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: mod_typing.ml 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 open Util
 open Names
@@ -17,6 +17,7 @@ open Environ
 open Term_typing
 open Modops
 open Subtyping
+open Mod_subst
 
 exception Not_path
 
@@ -65,8 +66,9 @@ and merge_with env mtb with_decl =
     | MTBsig(msid,sig_b) -> msid,sig_b 
     | _ -> error_signature_expected mtb
   in
-  let id = match with_decl with 
-    | With_Definition (id,_) | With_Module (id,_) -> id
+  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
@@ -74,7 +76,9 @@ and merge_with env mtb with_decl =
       let before = List.rev rev_before in
       let env' = Modops.add_signature (MPself msid) before env in
       let new_spec = match with_decl with
-	| With_Definition (id,c) -> 
+        | With_Definition ([],_)
+        | With_Module ([],_) -> assert false
+	| With_Definition ([id],c) -> 
 	    let cb = match spec with
 		SPBconst cb -> cb
 	      | _ -> error_not_a_constant l
@@ -88,21 +92,25 @@ and merge_with env mtb with_decl =
 		      let cst = 
 			Constraint.union 
 			  (Constraint.union cb.const_constraints cst1)
-			  cst2
-		      in
+			  cst2 in
+                      let body = Some (Declarations.from_val j.uj_val) in
 			SPBconst {cb with 
-				    const_body = 
-				      Some (Declarations.from_val j.uj_val);
-				    const_constraints = cst}
+				    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 = Some (Declarations.from_val c);
-				    const_constraints = cst}
+				    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) ->
+	| With_Module ([id], mp) ->
 	    let old = match spec with
 		SPBmodule msb -> msb
 	      | _ -> error_not_a_module (string_of_label l)
@@ -133,6 +141,29 @@ and merge_with env mtb with_decl =
 	       msb_constraints = Constraint.union old.msb_constraints cst }
 	    in
 	      SPBmodule msb
+	| With_Definition (_::_,_)
+        | With_Module (_::_,_) -> 
+	    let old = match spec with
+		SPBmodule 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
+              end
       in
 	MTBsig(msid,  before@(l,new_spec)::after)
     with
@@ -143,13 +174,14 @@ 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 ce in
+	  let cb = translate_constant env con ce in
 	    begin match cb.const_hyps with
 	      |	(_::_) -> error_local_context (Some l)
 	      | [] ->
-		  add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb)
+		  add_constant con cb env, (l, SEBconst cb), (l, SPBconst cb)
 	    end
       | SPEmind mie -> 
 	  let mib = translate_mind env mie in
@@ -253,8 +285,13 @@ and translate_mexpr env mexpr = match mexpr 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),
-	subst_modtype (map_mbid farg_id mp) fbody_b
+        (* 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),
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index fdf39c56..706c617c 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli,v 1.2.8.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: mod_typing.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (*i*)
 open Declarations
@@ -19,6 +19,8 @@ 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 add_modtype_constraints : env -> module_type_body -> env
 
 val add_module_constraints : env -> module_body -> env
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 84845af5..3d041c6c 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,v 1.12.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: modops.ml 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Util
@@ -17,6 +17,7 @@ open Term
 open Declarations
 open Environ
 open Entries
+open Mod_subst
 (*i*)
 
 let error_existing_label l = 
@@ -66,6 +67,11 @@ let error_not_a_constant l =
 let error_with_incorrect l =
   error ("Incorrect constraint for label \""^(string_of_label l)^"\"")
 
+let error_a_generative_module_expected l =
+  error ("The module " ^ string_of_label l ^ " is not generative. Only " ^
+         "component of generative modules can be changed using the \"with\" " ^
+         "construct.")
+
 let error_local_context lo = 
   match lo with
       None -> 
@@ -123,6 +129,9 @@ let rec check_modpath_equiv env mp1 mp2 =
 
 
 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 failwith "capture";
@@ -148,23 +157,77 @@ and subst_signature sub sign =
 
 and subst_module sub mb =
   let mtb' = subst_modtype sub mb.msb_modtype 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 subst_signature_msid msid mp = 
   subst_signature (map_msid msid mp)
 
+let rec constants_of_specification env mp sign =
+ let aux res (l,elem) =
+  match elem with
+   | SPBconst cb -> ((make_con mp empty_dirpath l),cb)::res
+   | SPBmind _ -> res
+   | SPBmodule mb ->
+      (constants_of_modtype env (MPdot (mp,l))
+        (module_body_of_spec mb).mod_type) @ res
+   | SPBmodtype mtb -> res (* ???? *)
+ in
+  List.fold_left aux [] 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 and then delta-expands
+   the obtained constants according to env *)
+let resolver_of_environment mbid modtype mp env =
+ let constants = constants_of_modtype env (MPbound mbid) modtype in
+ let resolve =
+  List.map
+   (fun (con,expecteddef) ->
+     let con' = replace_mp_in_con (MPbound mbid) mp con in
+     let constr =
+      try
+       if expecteddef.Declarations.const_body <> None then
+        (* Do not expand constants that already have a body in the
+           expected type (i.e. only parameters/axioms in the module type
+           are expanded). In the few examples we have this seems to
+           be the more reasonable behaviour for the user. *)
+        None
+       else
+        let constant = lookup_constant con' env in
+         if constant.Declarations.const_opaque then
+          None
+         else
+          option_app Declarations.force
+           constant.Declarations.const_body
+      with Not_found -> error_no_such_label (con_label con')
+     in
+      con,constr
+   ) constants
+ in
+  Mod_subst.make_resolver resolve
+
 (* we assume that the substitution of "mp" into "msid" is already done
 (or unnecessary) *)
 let rec add_signature mp sign env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
+    let con = make_con mp empty_dirpath l in
       match elem with
-	| SPBconst cb -> Environ.add_constant kn cb env
+	| 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 
@@ -180,7 +243,6 @@ and add_module mp mb env =
       | MTBident _ -> anomaly "scrape_modtype does not work!"
       | MTBsig (msid,sign) -> 
 	  add_signature mp (subst_signature_msid msid mp sign) env
-
       | MTBfunsig _ -> env
 
 
@@ -189,11 +251,13 @@ let strengthen_const env mp l cb =
   | false, Some _ -> cb
   | true, Some _ 
   | _, None -> 
-      let const = mkConst (make_kn mp empty_dirpath l) in 
+      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_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
@@ -243,3 +307,4 @@ and strengthen_sig env msid sign mp = match sign with
 	item::rest'
 
 let strengthen env mtb mp = strengthen_mtb env mp mtb
+
diff --git a/kernel/modops.mli b/kernel/modops.mli
index cca2d315..371860f5 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,v 1.7.6.2 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: modops.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -15,6 +15,7 @@ open Univ
 open Environ
 open Declarations
 open Entries
+open Mod_subst
 (*i*)
 
 (* Various operations on modules and module types *)
@@ -91,6 +92,11 @@ val error_not_a_constant : label -> 'a
 
 val error_with_incorrect : label -> 'a
 
+val error_a_generative_module_expected : label -> 'a
+
 val error_local_context : label option -> 'a
 
 val error_circular_with_module : identifier -> 'a
+
+val resolver_of_environment :
+ mod_bound_id -> module_type_body -> module_path -> env -> resolver
diff --git a/kernel/names.ml b/kernel/names.ml
index df3a012f..4c8cf7bb 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml,v 1.53.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: names.ml 7834 2006-01-11 00:15:01Z herbelin $ *)
 
 open Pp
 open Util
@@ -19,13 +19,7 @@ let id_ord = Pervasives.compare
 
 let id_of_string s = String.copy s
 
-let map_ident id =
-  if Options.do_translate() then
-    match id with
-        "fix" -> "Fix"
-      | _ -> id
-  else id
-let string_of_id id = String.copy (map_ident id)
+let string_of_id id = String.copy id
 
 (* Hash-consing of identifier *)
 module Hident = Hashcons.Make(
@@ -138,74 +132,6 @@ end
 module MPset = Set.Make(MPord)
 module MPmap = Map.Make(MPord)
 
-
-(* this is correct under the condition that bound and struct
-   identifiers can never be identical (i.e. get the same stamp)! *) 
-
-type substitution = module_path Umap.t
-
-let empty_subst = Umap.empty
-
-let add_msid = Umap.add 
-let add_mbid = Umap.add
-
-let map_msid msid mp = add_msid msid mp empty_subst
-let map_mbid mbid mp = add_msid mbid mp empty_subst
-
-let list_contents sub = 
-  let one_pair uid mp l =
-    (string_of_uid uid, string_of_mp mp)::l
-  in
-    Umap.fold one_pair sub []
-
-let debug_string_of_subst sub = 
-  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
-    "{" ^ String.concat "; " l ^ "}"
-
-let debug_pr_subst sub = 
-  let l = list_contents sub in
-  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
-  in
-    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
-
-let rec subst_mp sub mp = (* 's like subst *)
-  match mp with
-    | MPself sid -> 
-	(try Umap.find sid sub with Not_found -> mp)
-    | MPbound bid ->
-	(try Umap.find bid sub with Not_found -> mp)
-    | MPdot (mp1,l) -> 
-	let mp1' = subst_mp sub mp1 in
-	  if mp1==mp1' then 
-	    mp
-	  else
-	    MPdot (mp1',l)
-    | _ -> mp
-
-let join subst1 subst2 = 
-  let subst = Umap.map (subst_mp subst2) subst1 in
-  Umap.fold Umap.add subst2 subst
-
-let rec occur_in_path uid = function
-  | MPself sid -> sid = uid
-  | MPbound bid -> bid = uid
-  | MPdot (mp1,_) -> occur_in_path uid mp1
-  | _ -> false
-    
-let occur_uid uid sub = 
-  let check_one uid' mp =
-    if uid = uid' || occur_in_path uid mp then raise Exit
-  in
-    try 
-      Umap.iter check_one sub;
-      false
-    with Exit -> true
-
-let occur_msid = occur_uid
-let occur_mbid = occur_uid
-
-
-
 (* Kernel names *)
 
 type kernel_name = module_path * dir_path * label
@@ -225,11 +151,6 @@ let string_of_kn (mp,dir,l) =
 let pr_kn kn = str (string_of_kn kn)
 
 
-let subst_kn sub (mp,dir,l as kn) = 
-  let mp' = subst_mp sub mp in
-    if mp==mp' then kn else (mp',dir,l)
-
-
 let kn_ord kn1 kn2 = 
     let mp1,dir1,l1 = kn1 in
     let mp2,dir2,l2 = kn2 in
@@ -252,7 +173,9 @@ end
 module KNmap = Map.Make(KNord)
 module KNpred = Predicate.Make(KNord)
 module KNset = Set.Make(KNord)
-
+module Cmap = KNmap
+module Cpred = KNpred
+module Cset = KNset
 
 let default_module_name = id_of_string "If you see this, it's a bug"
 
@@ -267,11 +190,35 @@ type mutual_inductive = kernel_name
 type inductive = mutual_inductive * int
 type constructor = inductive * int
 
+let constant_of_kn kn = kn
+let make_con mp dir l = (mp,dir,l)
+let repr_con con = con
+let string_of_con = string_of_kn
+let con_label = label
+let pr_con = pr_kn
+let con_modpath = modpath
+
 let ith_mutual_inductive (kn,_) i = (kn,i)
 let ith_constructor_of_inductive ind i = (ind,i)
 let inductive_of_constructor (ind,i) = ind
 let index_of_constructor (ind,i) = i
 
+module InductiveOrdered = struct
+  type t = inductive
+  let compare (spx,ix) (spy,iy) = 
+    let c = ix - iy in if c = 0 then KNord.compare spx spy else c
+end
+
+module Indmap = Map.Make(InductiveOrdered)
+
+module ConstructorOrdered = struct
+  type t = constructor
+  let compare (indx,ix) (indy,iy) = 
+    let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
+end
+
+module Constrmap = Map.Make(ConstructorOrdered)
+
 (* Better to have it here that in closure, since used in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
@@ -352,4 +299,24 @@ let hcons_names () =
   let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in
   let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in
   let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in
-  (hkn,hdir,hname,hident,hstring)
+  (hkn,hkn,hdir,hname,hident,hstring)
+
+
+(*******)
+
+type transparent_state = Idpred.t * Cpred.t
+
+type 'a tableKey =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of 'a 
+
+
+type inv_rel_key = int (* index in the [rel_context] part of environment
+			  starting by the end, {\em inverse} 
+			  of de Bruijn indice *)
+
+type id_key = inv_rel_key tableKey
+
+
+
diff --git a/kernel/names.mli b/kernel/names.mli
index 07c19841..5b0a7a30 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,v 1.46.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: names.mli 6736 2005-02-18 20:49:04Z herbelin $ i*)
 
 (*s Identifiers *)
 
@@ -83,45 +83,6 @@ val string_of_mp : module_path -> string
 module MPset : Set.S with type elt = module_path
 module MPmap : Map.S with type key = module_path
 
-
-(*s Substitutions *)
-
-type substitution
-
-val empty_subst : substitution
-
-val add_msid : 
-  mod_self_id -> module_path -> substitution -> substitution
-val add_mbid : 
-  mod_bound_id -> module_path -> substitution -> substitution
-
-val map_msid : mod_self_id -> module_path -> substitution
-val map_mbid : mod_bound_id -> module_path -> substitution
-
-(* sequential composition: 
-   [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
-*)
-val join : substitution -> substitution -> substitution
-
-(*i debugging *)
-val debug_string_of_subst : substitution -> string
-val debug_pr_subst : substitution -> Pp.std_ppcmds
-(*i*)
-
-(* [subst_mp sub mp] guarantees that whenever the result of the
-   substitution is structutally equal [mp], it is equal by pointers 
-   as well [==] *) 
-
-val subst_mp : 
-  substitution -> module_path -> module_path
-
-(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
-   on either side *)
-
-val occur_msid : mod_self_id -> substitution -> bool
-val occur_mbid : mod_bound_id -> substitution -> bool
-     
-
 (* Name of the toplevel structure *)
 val initial_msid : mod_self_id
 val initial_path : module_path (* [= MPself initial_msid] *)
@@ -142,7 +103,6 @@ val label : kernel_name -> label
 
 val string_of_kn : kernel_name -> string
 val pr_kn : kernel_name -> Pp.std_ppcmds
-val subst_kn : substitution -> kernel_name -> kernel_name
 
 
 module KNset  : Set.S with type elt = kernel_name
@@ -153,13 +113,27 @@ module KNmap  : Map.S with type key = kernel_name
 (*s Specific paths for declarations *)
 
 type variable = identifier
-type constant = kernel_name
+type constant
 type mutual_inductive = kernel_name
 (* Beware: first inductive has index 0 *)
 type inductive = mutual_inductive * int
 (* Beware: first constructor has index 1 *)
 type constructor = inductive * int
 
+module Cmap  : Map.S with type key = constant
+module Cpred  : Predicate.S with type elt = constant
+module Cset  : Set.S with type elt = constant
+module Indmap : Map.S with type key = inductive
+module Constrmap : Map.S with type key = constructor
+
+val constant_of_kn : kernel_name -> constant
+val make_con : module_path -> dir_path -> label -> constant
+val repr_con : constant -> module_path * dir_path * label
+val string_of_con : constant -> string
+val con_label : constant -> label
+val con_modpath : constant -> module_path
+val pr_con : constant -> Pp.std_ppcmds
+
 val ith_mutual_inductive : inductive -> int -> inductive
 val ith_constructor_of_inductive : inductive -> int -> constructor
 val inductive_of_constructor : constructor -> inductive
@@ -172,5 +146,22 @@ type evaluable_global_reference =
 
 (* Hash-consing *)
 val hcons_names : unit ->
+  (constant -> constant) *
   (kernel_name -> kernel_name) * (dir_path -> dir_path) *
   (name -> name) * (identifier -> identifier) * (string -> string)
+
+
+(******)
+
+type 'a tableKey =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of 'a 
+
+type transparent_state = Idpred.t * Cpred.t
+
+type inv_rel_key = int (* index in the [rel_context] part of environment
+			  starting by the end, {\em inverse} 
+			  of de Bruijn indice *)
+
+type id_key = inv_rel_key tableKey
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
new file mode 100644
index 00000000..5a45c167
--- /dev/null
+++ b/kernel/pre_env.ml
@@ -0,0 +1,146 @@
+(************************************************************************)
+(*  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: pre_env.ml 7642 2005-12-06 08:56:29Z gregoire $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+
+type key = int option ref 
+
+type constant_key = constant_body * key
+ 
+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 }
+
+type stratification = {
+  env_universes : universes;
+  env_engagement : engagement option
+}
+
+type 'a val_kind =   
+  | VKvalue of values
+  | VKaxiom of 'a
+  | VKdef of constr
+
+type 'a lazy_val = 'a 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 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 }
+
+type named_context_val = named_context * named_vals
+
+let empty_named_context_val = [],[]
+
+let empty_env = { 
+  env_globals = {
+    env_constants = Cmap.empty;
+    env_inductives = KNmap.empty;
+    env_modules = MPmap.empty;
+    env_modtypes = KNmap.empty };
+  env_named_context = empty_named_context;
+  env_named_vals = [];
+  env_rel_context = empty_rel_context;
+  env_rel_val = [];
+  env_nb_rel = 0;
+  env_stratification = {
+    env_universes = initial_universes;
+    env_engagement = None } }
+
+
+(* 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 lookup_rel_val n env =
+  try List.nth env.env_rel_val (n - 1)
+  with _ -> raise Not_found
+    
+let env_of_rel n env =
+  { env with
+    env_rel_context = Util.list_skipn n env.env_rel_context;
+    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
+
+exception ASSERT of Sign.rel_context
+
+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 lookup_named_val id env =
+   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
+ 
+(* Global constants *)
+
+let lookup_constant_key kn env =
+  Cmap.find kn env.env_globals.env_constants
+
+let lookup_constant kn env =
+  fst (Cmap.find kn env.env_globals.env_constants)
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  KNmap.find kn env.env_globals.env_inductives
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
new file mode 100644
index 00000000..be74decf
--- /dev/null
+++ b/kernel/pre_env.mli
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: pre_env.mli 7642 2005-12-06 08:56:29Z gregoire $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+
+type key = int option ref 
+
+type constant_key = constant_body * key
+ 
+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 }
+
+type stratification = {
+  env_universes : universes;
+  env_engagement : engagement option
+}
+
+type 'a val_kind =   
+  | VKvalue of values
+  | VKaxiom of 'a
+  | VKdef of constr
+
+type 'a lazy_val = 'a 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 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 }
+
+type named_context_val = named_context * named_vals
+
+val empty_named_context_val : named_context_val
+
+val empty_env : env
+
+(* Rel context *)
+
+val nb_rel         : env -> int
+val push_rel       : rel_declaration -> env -> env
+val lookup_rel_val : int -> env -> rel_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 env_of_named     : identifier -> env -> env  
+(* Global constants *)
+
+
+val lookup_constant_key : constant -> env -> constant_key
+val lookup_constant : constant -> env -> constant_body
+
+(* Mutual Inductives *)
+val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
+
+
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 5428a40d..6477078a 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml,v 1.91.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: reduction.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
 
 open Util
 open Names
@@ -317,16 +317,15 @@ 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
+  ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
 
 let fconv cv_pb env t1 t2 =
-  if eq_constr t1 t2 then 
-    Constraint.empty
-  else
-    let infos = create_clos_infos betaiotazeta env in
-    ccnv cv_pb infos ELID ELID (inject t1) (inject t2)
-      Constraint.empty
+  if eq_constr t1 t2 then Constraint.empty
+  else clos_fconv cv_pb env t1 t2
 
+let conv_cmp = fconv
 let conv = fconv CONV
 let conv_leq = fconv CUMUL
 
@@ -341,6 +340,30 @@ let conv_leq_vecti env v1 v2 =
     v1
     v2
 
+(* option for conversion *)
+
+let vm_conv = ref fconv
+let set_vm_conv f = vm_conv := f
+let vm_conv cv_pb env t1 t2 = 
+  try 
+    !vm_conv cv_pb env t1 t2
+  with Not_found | Invalid_argument _ ->
+      (* If compilation fails, fall-back to closure conversion *)
+      clos_fconv cv_pb env t1 t2
+  
+
+let default_conv = ref fconv 
+
+let set_default_conv f = default_conv := f
+
+let default_conv cv_pb env t1 t2 = 
+  try 
+    !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
+  
+let default_conv_leq = default_conv CUMUL
 (*
 let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";;
 let conv_leq env t1 t2 =
@@ -393,7 +416,7 @@ let dest_prod_assum env =
     | LetIn (x,b,t,c) ->
         let d = (x,Some b,t) in
 	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
-    | Cast (c,_)    -> prodec_rec env l c
+    | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> l,rty
   in
   prodec_rec env Sign.empty_rel_context
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index c516ea70..a68e8697 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli,v 1.56.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: reduction.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Term
@@ -29,13 +29,28 @@ exception NotConvertible
 exception NotConvertibleVect of int
 type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
 
+type conv_pb = CONV | CUMUL
+
+val sort_cmp : 
+    conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints
+
 val conv_sort      : sorts conversion_function
 val conv_sort_leq  : sorts conversion_function
 
-val conv           : types conversion_function
+val conv_cmp       : conv_pb -> constr conversion_function
+
+val conv           : constr conversion_function
 val conv_leq       : types conversion_function
 val conv_leq_vecti : types array conversion_function
 
+(* option for conversion *)
+val set_vm_conv : (conv_pb -> types conversion_function) -> unit
+val vm_conv : conv_pb -> types conversion_function
+
+val set_default_conv : (conv_pb -> types conversion_function) -> unit
+val default_conv     : conv_pb -> types conversion_function
+val default_conv_leq : types conversion_function
+
 (************************************************************************)
 
 (* Builds an application node, reducing beta redexes it may produce. *) 
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 0f8c0d54..34071182 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,v 1.76.2.2 2005/11/23 14:46:08 barras Exp $ *)
+(* $Id: safe_typing.ml 7602 2005-11-23 15:10:16Z barras $ *)
 
 open Util
 open Names
@@ -132,15 +132,15 @@ let hcons_constant_body cb =
 
 let add_constant dir l decl senv =
   check_label l senv.labset;
-  let cb = match decl with 
-      ConstantEntry ce -> translate_constant senv.env ce
+  let kn = make_con senv.modinfo.modpath dir l in 
+  let cb = 
+    match decl with 
+    | ConstantEntry ce -> translate_constant senv.env kn ce
     | GlobalRecipe r ->
-        let cb = translate_recipe senv.env r in
-        if dir = empty_dirpath then hcons_constant_body cb else cb
+	let cb = translate_recipe senv.env kn r in
+	if dir = empty_dirpath then hcons_constant_body cb else cb
   in
-(*  let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*)
   let env' = Environ.add_constraints cb.const_constraints senv.env in
-  let kn = make_kn senv.modinfo.modpath dir l in
   let env'' = Environ.add_constant kn cb env' in
   kn, { old = senv.old;
 	env = env'';
@@ -417,7 +417,6 @@ let check_engagement env c =
 let set_engagement c senv =
   {senv with env = Environ.set_engagement c senv.env}
 
-
 (* Libraries = Compiled modules *)
 
 type compiled_library = 
@@ -517,7 +516,7 @@ let import (dp,mb,depends,engmt) digest senv =
 	  loads = (mp,mb)::senv.loads }
 
 
-(** Remove the body of opaque constants in modules *)
+(* Remove the body of opaque constants in modules *)
  
 let rec lighten_module mb =
   { mb with
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index b973fcde..148a9d9d 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,v 1.33.2.2 2005/11/23 14:46:08 barras Exp $ i*)
+(*i $Id: safe_typing.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Names
@@ -28,7 +28,6 @@ type safe_environment
 val env_of_safe_env : safe_environment -> Environ.env
 
 val empty_environment : safe_environment
-
 val is_empty : safe_environment -> bool
 
 (* Adding and removing local declarations (Local or Variables) *)
@@ -46,7 +45,7 @@ type global_declaration =
 
 val add_constant : 
   dir_path -> label -> global_declaration -> safe_environment -> 
-      kernel_name * safe_environment
+      constant * safe_environment
 
 (* Adding an inductive type *)
 val add_mind : 
@@ -68,7 +67,7 @@ val add_constraints :
   Univ.constraints -> safe_environment -> safe_environment
 
 (* Settin the strongly constructive or classical logical engagement *)
-val set_engagement : Environ.engagement -> safe_environment -> safe_environment
+val set_engagement : engagement -> safe_environment -> safe_environment
 
 
 (*s Interactive module functions *)
diff --git a/kernel/sign.ml b/kernel/sign.ml
index a4b2a2ea..7caf667f 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml,v 1.37.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: sign.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
 
 open Names
 open Util
@@ -53,13 +53,11 @@ let empty_rel_context = []
 
 let add_rel_decl d ctxt = d::ctxt
 
-let lookup_rel n sign =
-  let rec lookrec = function
-    | (1, decl :: _) -> decl
-    | (n, _ :: sign) -> lookrec (n-1,sign)
-    | (_, [])        -> raise Not_found
-  in 
-  lookrec (n,sign)
+let rec lookup_rel n sign =
+  match n, sign with
+  | 1, decl :: _ -> decl
+  | n, _ :: sign -> lookup_rel (n-1) sign
+  | _, []        -> raise Not_found
 
 let rel_context_length = List.length
 
@@ -73,7 +71,7 @@ let rel_context_nhyps hyps =
 let fold_rel_context f l ~init:x = List.fold_right f l x
 let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
 
-let map_rel_context f l = 
+let map_context f l =
   let map_decl (n, body_o, typ as decl) =
     let body_o' = option_smartmap f body_o in
     let typ' = f typ in
@@ -82,6 +80,9 @@ let map_rel_context f l =
   in
     list_smartmap map_decl l
 
+let map_rel_context = map_context
+let map_named_context = map_context
+
 (* Push named declarations on top of a rel context *)
 (* Bizarre. Should be avoided. *)
 let push_named_to_rel_context hyps ctxt =
@@ -121,7 +122,7 @@ let destArity =
     match kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
     | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
-    | Cast (c,_)      -> prodec_rec l c
+    | Cast (c,_,_)      -> prodec_rec l c
     | Sort s          -> l,s
     | _               -> anomaly "destArity: not an arity"
   in 
@@ -133,7 +134,7 @@ let rec isArity c =
   match kind_of_term c with
   | Prod (_,_,c)    -> isArity c
   | LetIn (_,b,_,c) -> isArity (subst1 b c)
-  | Cast (c,_)      -> isArity c
+  | Cast (c,_,_)      -> isArity c
   | Sort _          -> true
   | _               -> false
 
@@ -144,7 +145,7 @@ let decompose_prod_assum =
     match kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c
-    | Cast (c,_)      -> prodec_rec l c
+    | Cast (c,_,_)      -> prodec_rec l c
     | _               -> l,c
   in 
   prodec_rec empty_rel_context
@@ -156,7 +157,7 @@ let decompose_lam_assum =
     match kind_of_term c with
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
-    | Cast (c,_)      -> lamdec_rec l c
+    | Cast (c,_,_)      -> lamdec_rec l c
     | _               -> l,c
   in 
   lamdec_rec empty_rel_context
@@ -171,7 +172,7 @@ let decompose_prod_n_assum n =
     else match kind_of_term c with 
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
-    | Cast (c,_)      -> prodec_rec l n c
+    | Cast (c,_,_)      -> prodec_rec l n c
     | c -> error "decompose_prod_n_assum: not enough assumptions"
   in 
   prodec_rec empty_rel_context n
@@ -186,7 +187,7 @@ let decompose_lam_n_assum n =
     else match kind_of_term c with 
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
-    | Cast (c,_)      -> lamdec_rec l n c
+    | Cast (c,_,_)      -> lamdec_rec l n c
     | c -> error "decompose_lam_n_assum: not enough abstractions"
   in 
   lamdec_rec empty_rel_context n 
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 3f0549cc..4a90302b 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: sign.mli,v 1.40.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: sign.mli 6737 2005-02-18 20:49:43Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -62,6 +62,9 @@ val fold_rel_context_reverse :
 (*s Map function of [rel_context] *)
 val map_rel_context : (constr -> constr) -> rel_context -> rel_context
 
+(*s Map function of [named_context] *)
+val map_named_context : (constr -> constr) -> named_context -> named_context
+
 (*s Term constructors *)
 
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 835226fb..94251d90 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,v 1.11.2.2 2005/11/29 21:40:52 letouzey Exp $ i*)
+(*i $Id: subtyping.ml 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Util
@@ -18,6 +18,8 @@ open Environ
 open Reduction
 open Inductive
 open Modops
+open Mod_subst
+open Entries
 (*i*)
 
 (* This local type is used to subtype a constant with a constructor or
@@ -26,7 +28,6 @@ open Modops
 
 type namedobject = 
   | Constant of constant_body
-  | Mind of mutual_inductive_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
   | Module of module_specification_body
@@ -40,31 +41,27 @@ let add_nameobjects_of_mib ln mib map =
     let ip = (ln,j) in
     let map = 
       array_fold_right_i 
-	(fun i id map -> Idmap.add id (IndConstr ((ip,i), mib)) map)
-	oib.mind_consnames
-	map
+      (fun i id map ->
+        Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
+      oib.mind_consnames
+      map
     in
-      Idmap.add oib.mind_typename (IndType (ip, mib)) map
+      Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
   in
     array_fold_right_i add_nameobjects_of_one mib.mind_packets map
 
+
 (* creates namedobject map for the whole signature *)
 
-let make_label_map msid list = 
+let make_label_map mp list = 
   let add_one (l,e) map = 
-    let obj = 
-      match e with
-	| SPBconst cb -> Constant cb
-	| SPBmind mib -> Mind mib
-	| SPBmodule mb -> Module mb
-	| SPBmodtype mtb -> Modtype mtb
-    in
-(*    let map = match obj with
-      | Mind mib -> 
-	  add_nameobjects_of_mib (make_ln (MPself msid) l) mib map
-      | _ -> map
-    in *)
-      Labmap.add l obj map
+   let add_map obj = Labmap.add l obj map in
+   match e with
+    | SPBconst cb -> add_map (Constant cb)
+    | SPBmind 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)
   in
     List.fold_right add_one list Labmap.empty
 
@@ -81,8 +78,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
   let check_conv cst f = check_conv_error error cst f in
   let mib1 = 
     match info1 with
-      | Mind mib -> mib
-    (*  | IndType (_,mib) -> mib   we will enable this later*)
+      | IndType ((_,0), mib) -> mib
       | _ -> error ()
   in
   let check_packet cst p1 p2 =
@@ -118,8 +114,8 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 	    && Array.length mib2.mind_packets >= 1);
 
        (* TODO: we should allow renaming of parameters at least ! *)
-  check (fun mib -> mib.mind_packets.(0).mind_nparams);
-  check (fun mib -> mib.mind_packets.(0).mind_params_ctxt); 
+  check (fun mib -> mib.mind_nparams);
+  check (fun mib -> mib.mind_params_ctxt); 
 
   begin 
     match mib2.mind_equiv with
@@ -133,32 +129,19 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 	    if kn1 <> kn2 then error ()
   end;
   (* we check that records and their field names are preserved. *)
-  (* To stay compatible, we don't fail but only issue a warning. *)
-  if mib1.mind_record <> mib2.mind_record then begin
-    let sid = string_of_id mib1.mind_packets.(0).mind_typename in 
-    Pp.warning 
-      (sid^": record is implemented as an inductive type or conversely.\n"^
-	 "Beware that extraction cannot handle this situation.\n")
-  end; 
+  check (fun mib -> mib.mind_record);
   if mib1.mind_record then begin 
     let rec names_prod_letin t = match kind_of_term t with 
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
-      | Cast(t,_) -> names_prod_letin t
+      | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
     in 
     assert (Array.length mib1.mind_packets = 1);
     assert (Array.length mib2.mind_packets = 1);
     assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); 
     assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); 
-    let fields1 = names_prod_letin mib1.mind_packets.(0).mind_user_lc.(0)
-    and fields2 = names_prod_letin mib2.mind_packets.(0).mind_user_lc.(0) in  
-    if fields1 <> fields2 then 
-      let sid = string_of_id mib1.mind_packets.(0).mind_typename in 
-      Pp.warning 
-	(sid^": record has different field names in its signature and "^
-	   "implemantation.\n"^
-	   "Beware that extraction cannot handle this situation.\n");
+    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
   end;
   (* we first check simple things *)
   let cst = 
@@ -173,23 +156,43 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 let check_constant cst env msid1 l info1 cb2 spec2 = 
   let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
-  let cb1 = 
-    match info1 with
-      | Constant cb -> cb
-      | _ -> error ()
-  in 
-    assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-  (*Start by checking types*)
-    let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in
-    match cb2.const_body with
-      | None -> cst
-      | Some lc2 ->
-	  let c2 = Declarations.force lc2 in
-	  let c1 = match cb1.const_body with
-	    | Some lc1 -> Declarations.force lc1
-	    | None -> mkConst (make_kn (MPself msid1) empty_dirpath l)
-	  in
-	    check_conv cst conv env c1 c2
+  match info1 with
+   | Constant cb1 ->
+      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+      (*Start by checking types*)
+      let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in
+      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
+	       check_conv cst conv env c1 c2
+      in
+       cst
+   | IndType ((kn,i),mind1) ->
+      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 " ^
+       "name.") ;
+      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
+      if cb2.const_body <> None then error () ;
+      let arity1 = mind1.mind_packets.(i).mind_user_arity in
+       check_conv cst conv_leq env arity1 cb2.const_type
+   | IndConstr (((kn,i),j) as cstr,mind1) ->
+      Util.error ("The kernel does not recognize yet that a parameter can be " ^
+       "instantiated by a constructor. Hint: you can rename the " ^
+       "constructor and give a definition to map the old name to the new " ^
+       "name.") ;
+      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
+      if cb2.const_body <> None then error () ;
+      let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
+       check_conv cst conv env ty1 cb2.const_type
+   | _ -> error ()
 	      
 let rec check_modules cst env msid1 l msb1 msb2 =
   let mp = (MPdot(MPself msid1,l)) in
@@ -206,11 +209,11 @@ let rec check_modules cst env msid1 l msb1 msb2 =
   cst
 	
 
-and check_signatures cst env' (msid1,sig1) (msid2,sig2') = 
+and check_signatures cst env (msid1,sig1) (msid2,sig2') = 
   let mp1 = MPself msid1 in
-  let env = add_signature mp1 sig1 env' in 
+  let env = add_signature mp1 sig1 env in 
   let sig2 = subst_signature_msid msid2 mp1 sig2' in
-  let map1 = make_label_map msid1 sig1 in
+  let map1 = make_label_map mp1 sig1 in
   let check_one_body cst (l,spec2) = 
     let info1 = 
       try 
@@ -241,10 +244,10 @@ and check_signatures cst env' (msid1,sig1) (msid2,sig2') =
     List.fold_left check_one_body cst sig2
     
 and check_modtypes cst env mtb1 mtb2 equiv = 
-  if mtb1==mtb2 then (); (* just in case  :) *)
+  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 ();
+    if mtb1'==mtb2' then cst else
     match mtb1', mtb2' with
       | MTBsig (msid1,list1), 
 	MTBsig (msid2,list2) -> 
@@ -257,15 +260,17 @@ and check_modtypes cst env mtb1 mtb2 equiv =
 	MTBfunsig (arg_id2,arg_t2,body_t2) ->
 	  let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
 	    (* contravariant *)
-	  let env' = 
+	  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)) 
+              (map_mbid arg_id1 (MPbound arg_id2) None)
 	      body_t1
 	  in
-	  check_modtypes cst env' body_t1' body_t2 equiv
+	  check_modtypes cst env body_t1' body_t2 equiv
       | MTBident _ , _ -> anomaly "Subtyping: scrape failed"
       | _ , MTBident _ -> anomaly "Subtyping: scrape failed"
       | _ , _ -> error_incompatible_modtypes mtb1 mtb2
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index af09dafc..8bc25464 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,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Univ
diff --git a/kernel/term.ml b/kernel/term.ml
index 30e73e4f..7060d000 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml,v 1.95.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: term.ml 8049 2006-02-16 10:42:18Z coq $ *)
 
-(* This module instanciates the structure of generic deBruijn terms to Coq *)
+(* This module instantiates the structure of generic deBruijn terms to Coq *)
 
 open Util
 open Pp
@@ -21,6 +21,8 @@ open Esubst
 type existential_key = int
 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
@@ -31,6 +33,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
+    ci_cstr_nargs : int array; (* number of real args of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -56,6 +59,8 @@ let family_of_sort = function
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
+type cast_kind = VMcast | DEFAULTcast 
+
 (* [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
 type 'constr pexistential = existential_key * 'constr array
@@ -74,7 +79,7 @@ type ('constr, 'types) kind_of_term =
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
-  | Cast      of 'constr * 'types
+  | Cast      of 'constr * cast_kind * 'types
   | Prod      of name * 'types * 'types
   | Lambda    of name * 'types * 'constr
   | LetIn     of name * 'constr * 'types * 'constr
@@ -89,14 +94,14 @@ type ('constr, 'types) kind_of_term =
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types
+  | CastType   of 'types * 'types 
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
 
 let kind_of_type = function
   | Sort s -> SortType s
-  | Cast (c,t) -> CastType (c, t)
+  | Cast (c,_,t) -> CastType (c, t)
   | Prod (na,t,c) -> ProdType (na, t, c)
   | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
   | App (c,l) -> AtomicType (c, l)
@@ -123,7 +128,7 @@ let comp_term t1 t2 =
   | Meta m1, Meta m2 -> m1 == m2
   | Var id1, Var id2 -> id1 == id2
   | Sort s1, Sort s2 -> s1 == s2
-  | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2
+  | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2
   | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
   | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
   | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
@@ -148,19 +153,19 @@ let comp_term t1 t2 =
       & array_for_all2 (==) bl1 bl2
   | _ -> false
 
-let hash_term (sh_rec,(sh_sort,sh_kn,sh_na,sh_id)) t =
+let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t =
   match t with
   | Rel _ -> t
   | Meta x -> Meta x
   | Var x -> Var (sh_id x)
   | Sort s -> Sort (sh_sort s)
-  | Cast (c,t) -> Cast (sh_rec c, sh_rec t)
+  | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t))
   | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c)
   | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c)
   | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c)
   | App (c,l) -> App (sh_rec c, Array.map sh_rec l)
   | Evar (e,l) -> Evar (e, Array.map sh_rec l)
-  | Const c -> Const (sh_kn c)
+  | Const c -> Const (sh_con c)
   | Ind (kn,i) -> Ind (sh_kn kn,i)
   | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j)
   | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *)
@@ -179,15 +184,16 @@ module Hconstr =
     struct
       type t = constr
       type u = (constr -> constr) *
-               ((sorts -> sorts) * (kernel_name -> kernel_name)
-		* (name -> name) * (identifier -> identifier))
+               ((sorts -> sorts) * (constant -> constant) *
+               (kernel_name -> kernel_name) * (name -> name) *
+               (identifier -> identifier))
       let hash_sub = hash_term
       let equal = comp_term
       let hash = Hashtbl.hash
     end)
 
-let hcons_term (hsorts,hkn,hname,hident) =
-  Hashcons.recursive_hcons Hconstr.f (hsorts,hkn,hname,hident)
+let hcons_term (hsorts,hcon,hkn,hname,hident) =
+  Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident)
 
 (* Constructs a DeBrujin index with number n *)
 let rels =
@@ -206,11 +212,12 @@ let mkVar id = Var id
 let mkSort s = Sort s
 
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast (t1,t2) =
+(* (that means t2 is declared as the type of t1) 
+   [s] is the strategy to use when *)
+let mkCast (t1,k2,t2) =
   match t1 with
-    | Cast (t,_) -> Cast (t,t2)
-    | _ -> Cast (t1,t2)
+  | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2)
+  | _ -> Cast (t1,k2,t2)
 
 (* Constructs the product (x:t1)t2 *)
 let mkProd (x,t1,t2) = Prod (x,t1,t2)
@@ -225,7 +232,7 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
 (* We ensure applicative terms have at least one argument and the
    function is not itself an applicative term *)
 let mkApp (f, a) = 
-  if a=[||] then f else
+  if Array.length a = 0 then f else
     match f with
       | App (g, cl) -> App (g, Array.append cl a)
       | _ -> App (f, a)
@@ -309,22 +316,22 @@ let destSort c = match kind_of_term c with
 
 let rec isprop c = match kind_of_term c with
   | Sort (Prop _) -> true
-  | Cast (c,_) -> isprop c
+  | Cast (c,_,_) -> isprop c
   | _ -> false
 
 let rec is_Prop c = match kind_of_term c with
   | Sort (Prop Null) -> true
-  | Cast (c,_) -> is_Prop c
+  | Cast (c,_,_) -> is_Prop c
   | _ -> false
 
 let rec is_Set c = match kind_of_term c with
   | Sort (Prop Pos) -> true
-  | Cast (c,_) -> is_Set c
+  | Cast (c,_,_) -> is_Set c
   | _ -> false
 
 let rec is_Type c = match kind_of_term c with
   | Sort (Type _) -> true
-  | Cast (c,_) -> is_Type c
+  | Cast (c,_,_) -> is_Type c
   | _ -> false
 
 let isType = function
@@ -344,10 +351,11 @@ let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
 
 (* Destructs a casted term *)
 let destCast c = match kind_of_term c with 
-  | Cast (t1, t2) -> (t1,t2)
+  | Cast (t1,k,t2) -> (t1,k,t2)
   | _ -> invalid_arg "destCast"
 
-let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false
+let isCast c = match kind_of_term c with Cast _ -> true | _ -> false
+
 
 (* Tests if a de Bruijn index *)
 let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
@@ -374,12 +382,16 @@ let destLetIn c = match kind_of_term c with
   | _ -> invalid_arg "destProd"
 
 (* Destructs an application *)
-let destApplication c = match kind_of_term c with
+let destApp c = match kind_of_term c with
   | App (f,a) -> (f, a)
   | _ -> invalid_arg "destApplication"
 
+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
+
 (* Destructs a constant *)
 let destConst c = match kind_of_term c with
   | Const kn -> kn
@@ -423,24 +435,41 @@ let destCoFix c = match kind_of_term c with
   | _ -> invalid_arg "destCoFix"
 
 (******************************************************************)
+(* Cast management                                                *)
+(******************************************************************)
+
+let rec strip_outer_cast c = match kind_of_term c with
+  | Cast (c,_,_) -> strip_outer_cast c
+  | _ -> c
+
+(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
+
+let under_outer_cast f c =  match kind_of_term c with
+  | Cast (b,k,t) -> mkCast (f b, k, f t)
+  | _ -> f c
+
+let rec under_casts f c = match kind_of_term c with
+  | Cast (c,k,t) -> mkCast (under_casts f c, k, t)
+  | _            -> f c
+
+(******************************************************************)
 (* Flattening and unflattening of embedded applications and casts *)
 (******************************************************************)
 
-(* flattens application lists *)
+(* flattens application lists throwing casts in-between *)
 let rec collapse_appl c = match kind_of_term c with
   | App (f,cl) -> 
-      let rec collapse_rec f cl2 = match kind_of_term f with
+      let rec collapse_rec f cl2 =
+        match kind_of_term (strip_outer_cast f) with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| Cast (c,_) when isApp c -> collapse_rec c cl2
-	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
-      in 
+	| _ -> mkApp (f,cl2)
+      in
       collapse_rec f cl
   | _ -> c
 
-let rec decompose_app c =
-  match kind_of_term (collapse_appl c) with
+let decompose_app c =
+  match kind_of_term c with
     | App (f,cl) -> (f, Array.to_list cl)
-    | Cast (c,t) -> decompose_app c
     | _ -> (c,[])
 
 (* strips head casts and flattens head applications *)
@@ -448,11 +477,11 @@ let rec strip_head_cast c = match kind_of_term c with
   | App (f,cl) -> 
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| Cast (c,_) -> collapse_rec c cl2
-	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
+	| Cast (c,_,_) -> collapse_rec c cl2
+	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
       in 
       collapse_rec f cl
-  | Cast (c,t) -> strip_head_cast c
+  | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
 
 (****************************************************************************)
@@ -466,7 +495,7 @@ let rec strip_head_cast c = match kind_of_term c with
 let fold_constr f acc c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> acc
-  | Cast (c,t) -> f (f acc c) t
+  | 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
@@ -487,7 +516,7 @@ let fold_constr f acc c = match kind_of_term c with
 let iter_constr f c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
-  | Cast (c,t) -> f c; f t
+  | Cast (c,_,t) -> f c; f t
   | Prod (_,t,c) -> f t; f c
   | Lambda (_,t,c) -> f t; f c
   | LetIn (_,b,t,c) -> f b; f t; f c
@@ -506,7 +535,7 @@ let iter_constr f c = match kind_of_term c with
 let iter_constr_with_binders g f n c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
-  | Cast (c,t) -> f n c; f n t
+  | Cast (c,_,t) -> f n c; f n t
   | Prod (_,t,c) -> f n t; f (g n) c
   | Lambda (_,t,c) -> f n t; f (g n) c
   | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
@@ -527,7 +556,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with
 let map_constr f c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> mkCast (f c, f t)
+  | Cast (c,k,t) -> mkCast (f c, k, f t)
   | Prod (na,t,c) -> mkProd (na, f t, f c)
   | Lambda (na,t,c) -> mkLambda (na, f t, f c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c)
@@ -548,7 +577,7 @@ let map_constr f c = match kind_of_term c with
 let map_constr_with_binders g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> mkCast (f l c, f l t)
+  | Cast (c,k,t) -> mkCast (f l c, k, f l t)
   | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c)
   | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c)
@@ -573,8 +602,8 @@ let compare_constr f t1 t2 =
   | Meta m1, Meta m2 -> m1 = m2
   | Var id1, Var id2 -> id1 = id2
   | Sort s1, Sort s2 -> s1 = s2
-  | Cast (c1,_), _ -> f c1 t2
-  | _, Cast (c2,_) -> f t1 c2
+  | Cast (c1,_,_), _ -> f c1 t2
+  | _, Cast (c2,_,_) -> f t1 c2
   | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
   | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
   | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
@@ -605,6 +634,8 @@ let compare_constr f t1 t2 =
 
 type types = constr
 
+type strategy = types option 
+
 let type_app f tt = f tt
 
 let body_of_type ty = ty
@@ -671,7 +702,7 @@ let noccur_with_meta n m term =
     | Rel p -> if n<=p & p<n+m then raise LocalOccur
     | App(f,cl) ->
 	(match kind_of_term f with
-           | Cast (c,_) when isMeta c -> ()
+           | Cast (c,_,_) when isMeta c -> ()
            | Meta _ -> ()
 	   | _ -> iter_constr_with_binders succ occur_rec n c)
     | Evar (_, _) -> ()
@@ -746,7 +777,7 @@ let substl laml =
   substn_many (Array.map make_substituend (Array.of_list laml)) 0
 let subst1 lam = substl [lam]
 
-let substl_decl laml (id,bodyopt,typ as d) =
+let substl_decl laml (id,bodyopt,typ) =
   match bodyopt with
     | None -> (id,None,substl laml typ)
     | Some body -> (id, Some (substl laml body), type_app (substl laml) typ)
@@ -789,32 +820,6 @@ let substn_vars p vars =
 
 let subst_vars = substn_vars 1
 
-(* 
-map_kn : (kernel_name -> kernel_name) -> constr -> constr
-
-This should be rewritten to prevent duplication of constr's when not
-necessary.
-For now, it uses map_constr and is rather ineffective
-*)
-
-let rec map_kn f c = 
-  let func = map_kn f in
-    match kind_of_term c with
-      | Const kn -> 
-	  mkConst (f kn)
-      | Ind (kn,i) -> 
-	  mkInd (f kn,i)
-      | Construct ((kn,i),j) -> 
-	  mkConstruct ((f kn,i),j)
-      | Case (ci,p,c,l) ->
-	  let ci' = { ci with ci_ind = let (kn,i) = ci.ci_ind in f kn, i } in
-	  mkCase (ci', func p, func c, array_smartmap func l) 
-      | _ -> map_constr func c
-
-let subst_mps sub = 
-  map_kn (subst_kn sub)
-
-
 (*********************)
 (* Term constructors *)
 (*********************)
@@ -965,20 +970,6 @@ let mkCoFix = mkCoFix
 let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0))
 let mkImplicit = mkSort implicit_sort
 
-let rec strip_outer_cast c = match kind_of_term c with
-  | Cast (c,_) -> strip_outer_cast c
-  | _ -> c
-
-(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
-
-let under_outer_cast f c =  match kind_of_term c with
-  | Cast (b,t) -> mkCast (f b,f t)
-  | _ -> f c
-
-let rec under_casts f c = match kind_of_term c with
-  | Cast (c,t) -> mkCast (under_casts f c, t)
-  | _            -> f c
-
 (***************************)
 (* Other term constructors *)
 (***************************)
@@ -1027,7 +1018,7 @@ let rec to_lambda n prod =
   else 
     match kind_of_term prod with 
       | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
-      | Cast (c,_) -> to_lambda n c
+      | Cast (c,_,_) -> to_lambda n c
       | _   -> errorlabstrm "to_lambda" (mt ())                      
 
 let rec to_prod n lam =
@@ -1036,7 +1027,7 @@ let rec to_prod n lam =
   else   
     match kind_of_term lam with 
       | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
-      | Cast (c,_) -> to_prod n c
+      | Cast (c,_,_) -> to_prod n c
       | _   -> errorlabstrm "to_prod" (mt ())                      
 	    
 (* pseudo-reduction rule:
@@ -1066,7 +1057,7 @@ let prod_applist t nL = List.fold_left prod_app t nL
 let decompose_prod = 
   let rec prodec_rec l c = match kind_of_term c with
     | Prod (x,t,c) -> prodec_rec ((x,t)::l) c
-    | Cast (c,_)   -> prodec_rec l c
+    | Cast (c,_,_)   -> prodec_rec l c
     | _              -> l,c
   in 
   prodec_rec []
@@ -1076,7 +1067,7 @@ let decompose_prod =
 let decompose_lam = 
   let rec lamdec_rec l c = match kind_of_term c with
     | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
-    | Cast (c,_)     -> lamdec_rec l c
+    | Cast (c,_,_)     -> lamdec_rec l c
     | _                -> l,c
   in 
   lamdec_rec []
@@ -1089,7 +1080,7 @@ let decompose_prod_n n =
     if n=0 then l,c 
     else match kind_of_term c with 
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
-      | Cast (c,_)   -> prodec_rec l n c
+      | Cast (c,_,_)   -> prodec_rec l n c
       | _ -> error "decompose_prod_n: not enough products"
   in 
   prodec_rec [] n 
@@ -1102,7 +1093,7 @@ let decompose_lam_n n =
     if n=0 then l,c 
     else match kind_of_term c with 
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
-      | Cast (c,_)     -> lamdec_rec l n c
+      | Cast (c,_,_)     -> lamdec_rec l n c
       | _ -> error "decompose_lam_n: not enough abstractions"
   in 
   lamdec_rec [] n 
@@ -1112,7 +1103,7 @@ let decompose_lam_n n =
 let nb_lam = 
   let rec nbrec n c = match kind_of_term c with
     | Lambda (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_) -> nbrec n c
+    | Cast (c,_,_) -> nbrec n c
     | _ -> n
   in 
   nbrec 0
@@ -1121,7 +1112,7 @@ let nb_lam =
 let nb_prod = 
   let rec nbrec n c = match kind_of_term c with
     | Prod (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_) -> nbrec n c
+    | Cast (c,_,_) -> nbrec n c
     | _ -> n
   in 
   nbrec 0
@@ -1137,6 +1128,7 @@ let nb_prod =
 let rec eq_constr m n = 
   (m==n) or
   compare_constr eq_constr m n
+
 let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
 
 (*******************)
@@ -1177,10 +1169,18 @@ module Hsorts =
 
 let hsort = Hsorts.f
 
-let hcons_constr (hkn,hdir,hname,hident,hstr) =
+let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) =
   let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
-  let hcci = hcons_term (hsortscci,hkn,hname,hident) in
+  let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in
   let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
   (hcci,htcci)
 
 let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
+
+
+(*******)
+(* Type of abstract machine values *)
+type values
+
+
+
diff --git a/kernel/term.mli b/kernel/term.mli
index a5e5c081..0eccd170 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli,v 1.101.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: term.mli 8049 2006-02-16 10:42:18Z coq $ i*)
 
 (*i*)
 open Names
 (*i*)
 
+
 (*s The sorts of CCI. *)
 
 type contents = Pos | Null
@@ -49,6 +50,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
+    ci_cstr_nargs : int array; (* number of real args of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -99,9 +101,13 @@ val mkProp : types
 val mkSet  : types
 val mkType : Univ.universe -> types
 
+
+(* This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | DEFAULTcast 
+
 (* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the 
    type $t_2$ (that means t2 is declared as the type of t1). *)
-val mkCast : constr * types -> constr
+val mkCast : constr * cast_kind * constr -> constr
 
 (* Constructs the product [(x:t1)t2] *)
 val mkProd : name * types * types -> types
@@ -192,7 +198,7 @@ type ('constr, 'types) kind_of_term =
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
-  | Cast      of 'constr * 'types
+  | Cast      of 'constr * cast_kind * 'types
   | Prod      of name * 'types * 'types
   | Lambda    of name * 'types * 'constr
   | LetIn     of name * 'constr * 'types * 'constr
@@ -213,7 +219,7 @@ val kind_of_term : constr -> (constr, types) kind_of_term
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types
+  | CastType   of 'types * 'types 
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
@@ -230,6 +236,7 @@ val isMeta : constr -> bool
 val isSort : constr -> bool
 val isCast : constr -> bool
 val isApp : constr -> bool
+val isProd : constr -> bool
 val isConst : constr -> bool
 val isConstruct : constr -> bool
 
@@ -258,7 +265,7 @@ val destVar : constr -> identifier
 val destSort : constr -> sorts
 
 (* Destructs a casted term *)
-val destCast : constr -> constr * types
+val destCast : constr -> constr * cast_kind * constr
 
 (* Destructs the product $(x:t_1)t_2$ *)
 val destProd : types -> name * types * types
@@ -270,8 +277,12 @@ val destLambda : constr -> name * types * constr
 val destLetIn : constr -> name * constr * types * constr
 
 (* Destructs an application *)
+val destApp : constr -> constr * constr array
+
+(* Obsolete synonym of destApp *)
 val destApplication : constr -> constr * constr array
-(* ... removing casts *)
+
+(* Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
 (* Destructs a constant *)
@@ -410,6 +421,9 @@ val strip_outer_cast : constr -> constr
 (* Apply a function letting Casted types in place *)
 val under_casts : (constr -> constr) -> constr -> constr
 
+(* Apply a function under components of Cast if any *)
+val under_outer_cast : (constr -> constr) -> constr -> constr
+
 (*s Occur checks *)
 
 (* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
@@ -460,11 +474,6 @@ val subst_vars : identifier list -> constr -> constr
 val substn_vars : int -> identifier list -> constr -> constr
 
 
-(* [subst_mps sub c] performs the substitution [sub] on all kernel
-   names appearing in [c] *)
-val subst_mps : substitution -> constr -> constr
-
-
 (*s Functionals working on the immediate subterm of a construction *)
 
 (* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
@@ -512,6 +521,7 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 (*********************************************************************)
 
 val hcons_constr:
+  (constant -> constant) *
   (kernel_name -> kernel_name) *
   (dir_path -> dir_path) *
   (name -> name) *
@@ -523,3 +533,7 @@ val hcons_constr:
 
 val hcons1_constr : constr -> constr
 val hcons1_types : types -> types
+
+(**************************************)
+
+type values
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 5347583f..fde5fa25 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,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *)
+(* $Id: term_typing.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
 
 open Util
 open Names
@@ -26,15 +26,9 @@ let constrain_type env j cst1 = function
   | None -> j.uj_type, cst1
   | Some t -> 
       let (tj,cst2) = infer_type env t in
-      let cst3 =
-	try conv_leq env j.uj_type tj.utj_val
-	with NotConvertible -> error_actual_type env j tj.utj_val in
-      let typ = 
-        if t = tj.utj_val then t else
-          (error "Kernel built a type different from its input\n";
-           flush stdout; tj.utj_val) in
-      typ, Constraint.union (Constraint.union cst1 cst2) cst3
-
+      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
+      assert (t = tj.utj_val);
+      t, Constraint.union (Constraint.union cst1 cst2) cst3
 
 let translate_local_def env (b,topt) =
   let (j,cst) = infer env b in
@@ -85,33 +79,38 @@ let infer_declaration env dcl =
   | DefinitionEntry c ->
       let (j,cst) = infer env c.const_entry_body in
       let (typ,cst) = constrain_type env j cst c.const_entry_type in
-      Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque
+      Some (Declarations.from_val j.uj_val), typ, cst,
+        c.const_entry_opaque, c.const_entry_boxed
   | ParameterEntry t ->
       let (j,cst) = infer env t in
-      None, Typeops.assumption_of_judgment env j, cst, false
+      None, Typeops.assumption_of_judgment env j, cst, false, false
 
-let build_constant_declaration env (body,typ,cst,op) =
-  let ids = match body with 
+let build_constant_declaration env kn (body,typ,cst,op,boxed) =
+  let ids =
+    match body with 
     | None -> global_vars_set env typ
     | Some b ->
         Idset.union 
 	  (global_vars_set env (Declarations.force b)) 
-	  (global_vars_set env typ) 
+	  (global_vars_set env typ)
   in
+  let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in
   let hyps = keep_hyps env ids in
-    { const_body = body;
+    { const_hyps = hyps;
+      const_body = body;
       const_type = typ;
-      const_hyps = hyps;
+      const_body_code = tps;
+     (* const_type_code = to_patch env typ;*)
       const_constraints = cst;
       const_opaque = op }
 
 (*s Global and local constant declaration. *)
 
-let translate_constant env ce =
-  build_constant_declaration env (infer_declaration env ce)
+let translate_constant env kn ce =
+  build_constant_declaration env kn (infer_declaration env ce)
 
-let translate_recipe env r = 
-  build_constant_declaration env (Cooking.cook_constant env r)
+let translate_recipe env kn r = 
+  build_constant_declaration env kn (Cooking.cook_constant env r)
 
 (* Insertion of inductive types. *)
 
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 67d479ba..cf111b6b 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,v 1.2.8.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+(*i $Id: term_typing.mli 6245 2004-10-20 13:50:08Z barras $ i*)
 
 (*i*)
 open Names
@@ -24,11 +24,11 @@ val translate_local_def : env -> constr * types option ->
 
 val translate_local_assum : env -> types ->
   types * Univ.constraints
-
-val translate_constant : env -> constant_entry -> constant_body
+ 
+val translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind : 
   env -> mutual_inductive_entry -> mutual_inductive_body
 
 val translate_recipe : 
-  env -> Cooking.recipe -> constant_body
+  env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index c3d4726f..3807ecdb 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,v 1.31.2.1 2004/07/16 19:30:27 herbelin Exp $ *)
+(* $Id: type_errors.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
 
 open Names
 open Term
@@ -19,7 +19,7 @@ open Reduction
 type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
-  | RecursionNotOnInductiveType
+  | RecursionNotOnInductiveType of constr
   | RecursionOnIllegalTerm of int * constr * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
@@ -103,7 +103,7 @@ let error_cant_apply_not_functional env rator randl =
   raise (TypeError (env, CantApplyNonFunctional (rator,randl)))
 
 let error_cant_apply_bad_type env t rator randl =
-  raise(TypeError (env, CantApplyBadType (t,rator,randl)))
+  raise (TypeError (env, CantApplyBadType (t,rator,randl)))
 
 let error_ill_formed_rec_body env why lna i =
   raise (TypeError (env, IllFormedRecBody (why,lna,i)))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 2e8a7138..c56b174b 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,v 1.36.2.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+(*i $Id: type_errors.mli 6019 2004-08-06 18:15:24Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,7 +21,7 @@ open Environ
 type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
-  | RecursionNotOnInductiveType
+  | RecursionNotOnInductiveType of constr
   | RecursionOnIllegalTerm of int * constr * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 66b2e24d..779a427a 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml,v 1.89.2.1 2004/07/16 19:30:28 herbelin Exp $ *)
+(* $Id: typeops.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
 
 open Util
 open Names
@@ -19,11 +19,24 @@ open Entries
 open Reduction
 open Inductive
 open Type_errors
-
+  
+let conv = default_conv CONV
+let conv_leq = default_conv CUMUL
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i c t1 t2 ->
+      let c' =
+        try default_conv CUMUL env t1 t2 
+        with NotConvertible -> raise (NotConvertibleVect i) in
+      Constraint.union c c')
+    Constraint.empty
+    v1
+    v2
 
 (* This should be a type (a priori without intension to be an assumption) *)
 let type_judgment env j =
-  match kind_of_term(whd_betadeltaiota env (body_of_type j.uj_type)) with
+  match kind_of_term(whd_betadeltaiota env j.uj_type) with
     | Sort s -> {utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -34,11 +47,9 @@ let assumption_of_judgment env j =
   with TypeError _ ->
     error_assumption env j
 
-(*
-let aojkey = Profile.declare_profile "assumption_of_judgment";;
-let assumption_of_judgment env j
-  = Profile.profile2 aojkey assumption_of_judgment env j;;
-*)
+let sort_judgment env j = (type_judgment env j).utj_type
+
+let on_judgment_type f j = { j with uj_type = f j.uj_type }
 
 (************************************************)
 (* Incremental typing rules: builds a typing judgement given the *)
@@ -49,11 +60,11 @@ let assumption_of_judgment env j
 (* Prop and Set *)
 
 let judge_of_prop =
-  { uj_val = body_of_type mkProp;
+  { uj_val = mkProp;
     uj_type = mkSort type_0 }
 
 let judge_of_set =
-  { uj_val = body_of_type mkSet;
+  { uj_val = mkSet;
     uj_type = mkSort type_0 }
 
 let judge_of_prop_contents = function
@@ -64,7 +75,7 @@ let judge_of_prop_contents = function
 
 let judge_of_type u =
   let uu = super u in
-  { uj_val = body_of_type (mkType u);
+  { uj_val = mkType u;
     uj_type = mkType uu }
 
 (*s Type of a de Bruijn index. *)
@@ -77,30 +88,23 @@ let judge_of_relative env n =
   with Not_found -> 
     error_unbound_rel env n
 
-(*
-let relativekey = Profile.declare_profile "judge_of_relative";;
-let judge_of_relative env n =
-  Profile.profile2 relativekey judge_of_relative env n;;
-*)
-
 (* Type of variables *)
 let judge_of_variable env id =
   try
-    let (_,_,ty) = lookup_named id env in
+    let ty = named_type id env in
     make_judge (mkVar id) ty
   with Not_found -> 
     error_unbound_var env id
 
 (* Management of context of variables. *)
 
-(* Checks if a context of variable can be instanciated by the
+(* Checks if a context of variable can be instantiated by the
    variables of the current env *)
 (* TODO: check order? *)
 let rec check_hyps_inclusion env sign =
-  let env_sign = named_context env in
   Sign.fold_named_context
     (fun (id,_,ty1) () ->
-      let (_,_,ty2) = Sign.lookup_named id env_sign in
+      let ty2 = named_type id env in
       if not (eq_constr ty2 ty1) then
         error "types do not match")
     sign
@@ -108,7 +112,6 @@ let rec check_hyps_inclusion env sign =
 
 
 let check_args env c hyps =
-  let hyps' = named_context env in
   try check_hyps_inclusion env hyps
   with UserError _ | Not_found ->
     error_reference_variables env c
@@ -132,12 +135,6 @@ let judge_of_constant env cst =
     check_args env constr ce.const_hyps in 
   make_judge constr (constant_type env cst)
 
-(*
-let tockey = Profile.declare_profile "type_of_constant";;
-let type_of_constant env c 
-  = Profile.profile3 tockey type_of_constant env c;;
-*)
-
 (* Type of a lambda-abstraction. *)
 
 (* [judge_of_abstraction env name var j] implements the rule
@@ -203,9 +200,11 @@ let sort_of_product env domsort rangsort =
           rangsort
         else
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          domsort
+          Type (sup u1 base_univ)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop _,  Type _)  -> rangsort
+    | (Prop Pos,  Type u2)  -> Type (sup base_univ u2)
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Null, Type _)  -> rangsort
     (* Product rule (Type_i,Type_i,Type_i) *) 
     | (Type u1, Type u2) -> Type (sup u1 u2)
 
@@ -231,11 +230,14 @@ let judge_of_product env name t1 t2 =
          env |- c:typ2
 *)
 
-let judge_of_cast env cj tj =
+let judge_of_cast env cj k tj =
   let expected_type = tj.utj_val in
   try 
-    let cst = conv_leq env cj.uj_type expected_type in
-    { uj_val = mkCast (j_val cj, expected_type);
+    let cst = 
+      match k with
+      | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
+      | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
+    { uj_val = mkCast (cj.uj_val, k, expected_type);
       uj_type = expected_type },
     cst
   with NotConvertible ->
@@ -249,13 +251,8 @@ let judge_of_inductive env i =
     let (kn,_) = i in
     let mib = lookup_mind kn env in
     check_args env constr mib.mind_hyps in 
-  make_judge constr (type_of_inductive env i)
-
-(*
-let toikey = Profile.declare_profile "judge_of_inductive";;
-let judge_of_inductive env i
-  = Profile.profile2 toikey judge_of_inductive env i;;
-*)
+  let specif = lookup_mind_specif env i in
+  make_judge constr (type_of_inductive specif)
 
 (* Constructors. *)
 
@@ -265,21 +262,16 @@ let judge_of_constructor env c =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
     check_args env constr mib.mind_hyps in 
-  make_judge constr (type_of_constructor env c)
-
-(*
-let tockey = Profile.declare_profile "judge_of_constructor";;
-let judge_of_constructor env cstr
-  = Profile.profile2 tockey judge_of_constructor env cstr;;
-*)
+  let specif = lookup_mind_specif env (inductive_of_constructor c) in
+  make_judge constr (type_of_constructor c specif)
 
 (* Case. *)
 
-let check_branch_types env cj (lft,explft) = 
-  try conv_leq_vecti env lft explft
+let check_branch_types env cj (lfj,explft) = 
+  try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i)
+        error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
@@ -290,20 +282,12 @@ let judge_of_case env ci pj cj lfj =
   let _ = check_case_info env (fst indspec) ci in
   let (bty,rslty,univ) =
     type_case_branches env indspec pj cj.uj_val in
-  let (_,kind) = dest_arity env pj.uj_type in
-  let lft = Array.map j_type lfj in
-  let univ' = check_branch_types env cj (lft,bty) in
+  let univ' = check_branch_types env cj (lfj,bty) in
   ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
                        Array.map j_val lfj);
      uj_type = rslty },
   Constraint.union univ univ')
 
-(*
-let tocasekey = Profile.declare_profile "judge_of_case";;
-let judge_of_case env ci pj cj lfj
-  = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;;
-*)
-
 (* Fixpoints. *)
 
 (* Checks the type of a general (co)fixpoint, i.e. without checking *)
@@ -313,9 +297,7 @@ let type_fixpoint env lna lar vdefj =
   let lt = Array.length vdefj in
   assert (Array.length lar = lt);
   try
-    conv_leq_vecti env
-      (Array.map (fun j -> body_of_type j.uj_type) vdefj)
-      (Array.map (fun ty -> lift lt ty) lar)
+    conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar)
   with NotConvertibleVect i ->
     error_ill_typed_rec_body env i lna vdefj lar
 
@@ -354,8 +336,12 @@ let rec execute env cstr cu =
     | App (f,args) ->
 	let (j,cu1) = execute env f cu in
         let (jl,cu2) = execute_array env args cu1 in
-	univ_combinator cu2
-	  (judge_of_apply env j jl)
+	let (j',cu) = univ_combinator cu2 (judge_of_apply env j jl) in
+	if isInd f then
+	  (* Sort-polymorphism of inductive types *)
+	  adjust_inductive_level env (destInd f) args (j',cu)
+	else
+	  (j',cu)
 	    
     | Lambda (name,c1,c2) -> 
         let (varj,cu1) = execute_type env c1 cu in
@@ -372,16 +358,17 @@ let rec execute env cstr cu =
     | LetIn (name,c1,c2,c3) ->
         let (j1,cu1) = execute env c1 cu in
         let (j2,cu2) = execute_type env c2 cu1 in
-        let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 j2) in
+        let (_,cu3) = 
+	  univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in
         let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
         let (j',cu4) = execute env1 c3 cu3 in
         (judge_of_letin env name j1 j2 j', cu4)
 	  
-    | Cast (c,t) ->
+    | Cast (c,k, t) ->
         let (cj,cu1) = execute env c cu in
         let (tj,cu2) = execute_type env t cu1 in
 	univ_combinator cu2
-          (judge_of_cast env cj tj)
+          (judge_of_cast env cj k tj)
 
     (* Inductive types *)
     | Ind ind ->
@@ -430,27 +417,32 @@ and execute_recdef env (names,lar,vdef) i cu =
   univ_combinator cu2
     ((lara.(i),(names,lara,vdefv)),cst)
 
-and execute_array env v cu =
-  let (jl,cu1) = execute_list env (Array.to_list v) cu in
-  (Array.of_list jl, cu1)
-
-and execute_list env l cu =
-  match l with
-  | [] -> 
-      ([], cu)
-  | c::r -> 
-      let (j,cu1) = execute env c cu in 
-      let (jr,cu2) = execute_list env r cu1 in
-      (j::jr, cu2)
+and execute_array env = array_fold_map' (execute env)
+
+and execute_list env = list_fold_map' (execute env) 
+
+and adjust_inductive_level env ind args (j,cu) =
+  let specif = lookup_mind_specif env ind in
+  if is_small_inductive specif then
+    (* No polymorphism *)
+    (j,cu)
+  else
+    (* Retyping constructor with the actual arguments *)
+    let env',llc,ls0 = constructor_instances env specif ind args in
+    let (llj,cu1) = array_fold_map' (execute_array env') llc cu in
+    let ls =
+      Array.map (fun lj ->
+	max_inductive_sort (Array.map (sort_judgment env) lj)) llj
+    in
+    let s = find_inductive_level env specif ind ls0 ls in
+    (on_judgment_type (set_inductive_level env s) j, cu1)
 
 (* Derived functions *)
 let infer env constr =
   let (j,(cst,_)) =
     execute env constr (Constraint.empty, universes env) in
-  let j = if j.uj_val = constr then { j with uj_val = constr } else
-    (error "Kernel built a body different from its input\n";
-     flush stdout; j) in
-  (j, cst)
+  assert (j.uj_val = constr);
+  ({ j with uj_val = constr }, cst)
 
 let infer_type env constr =
   let (j,(cst,_)) =
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index ffe9d861..34ecd103 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,v 1.44.8.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+(*i $Id: typeops.mli 8673 2006-03-29 21:21:52Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -33,6 +33,8 @@ val infer_local_decls :
 
 val assumption_of_judgment :  env -> unsafe_judgment -> types
 val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
+val on_judgment_type       :  
+  (types -> types) -> unsafe_judgment -> unsafe_judgment
 
 (*s Type of sorts. *)
 val judge_of_prop_contents : contents -> unsafe_judgment
@@ -69,8 +71,8 @@ val judge_of_letin :
 
 (*s Type of a cast. *)
 val judge_of_cast :
-  env -> unsafe_judgment -> unsafe_type_judgment
-    -> unsafe_judgment * constraints
+  env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
+    unsafe_judgment * constraints
 
 (*s Inductive types. *)
 
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 5e9fbd81..23e50282 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -6,29 +6,41 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml,v 1.17.10.3 2005/09/08 12:27:46 herbelin Exp $ *)
+(* $Id: univ.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
 
-(* Universes are stratified by a partial ordering $\ge$.
+(* Universes are stratified by a partial ordering $\le$.
    Let $\~{}$ be the associated equivalence. We also have a strict ordering
-   $>$ between equivalence classes, and we maintain that $>$ is acyclic,
-   and contained in $\ge$ in the sense that $[U]>[V]$ implies $U\ge V$.
+   $<$ between equivalence classes, and we maintain that $<$ is acyclic,
+   and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$.
 
    At every moment, we have a finite number of universes, and we
-   maintain the ordering in the presence of assertions $U>V$ and $U\ge V$.
+   maintain the ordering in the presence of assertions $U<V$ and $U\le V$.
 
    The equivalence $\~{}$ is represented by a tree structure, as in the
-   union-find algorithm. The assertions $>$ and $\ge$ are represented by
+   union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
 open Pp
 open Util
 
+(* An algebraic universe [universe] is either a universe variable
+   [universe_level] or a formal universe known to be greater than some
+   universe variables and strictly greater than some (other) universe
+   variables
+
+   Universes variables denote universes initially present in the term
+   to type-check and non variable algebraic universes denote the
+   universes inferred while type-checking: it is either the successor
+   of a universe present in the initial term to type-check or the
+   maximum of two algebraic universes
+ *)
+
 type universe_level =
-    { u_mod : Names.dir_path;
-      u_num : int }
+  | Base
+  | Level of Names.dir_path * int
 
 type universe =
-  | Variable of universe_level
+  | Atom of universe_level
   | Max of universe_level list * universe_level list
   
 module UniverseOrdered = struct
@@ -36,61 +48,60 @@ module UniverseOrdered = struct
   let compare = Pervasives.compare
 end
 
-let string_of_univ_level u =
-  Names.string_of_dirpath u.u_mod^"."^string_of_int u.u_num
+let string_of_univ_level = function
+  | Base -> "0"
+  | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
 
-let make_univ (m,n) = Variable { u_mod=m; u_num=n }
-
-let string_of_univ = function
-  | Variable u -> string_of_univ_level u
-  | Max (gel,gtl) -> 
-      "max("^
-      (String.concat ","
-	 ((List.map string_of_univ_level gel)@
-	  (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")"
+let make_univ (m,n) = Atom (Level (m,n))
 
 let pr_uni_level u = str (string_of_univ_level u)
 
 let pr_uni = function
-  | Variable u -> 
+  | Atom u -> 
       pr_uni_level u
+  | Max ([],[Base]) ->
+      int 1
   | Max (gel,gtl) ->
-      str "max(" ++ 
-      prlist_with_sep pr_coma pr_uni_level gel ++
-      (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++
-      prlist_with_sep pr_coma
-	(fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++
+      str "max(" ++ hov 0
+       (prlist_with_sep pr_coma pr_uni_level gel ++
+	  (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++
+	prlist_with_sep pr_coma
+	  (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++
       str ")"
 
-(* Returns a fresh universe, juste above u. Does not create new universes
-   for Type_0 (the sort of Prop and Set).
+(* Returns the formal universe that lies juste above the universe variable u.
    Used to type the sort u. *)
 let super = function
-  | Variable u -> 
+  | 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 universes:\n"^
                "(maybe a bugged tactic)")
 
-(* returns the least upper bound of universes u and v. If they are not
-   constrained, then a new universe is created.
+(* Returns the formal universe that is greater than the universes u and v.
    Used to type the products. *)
-let sup u v = 
+let sup u v =
   match u,v with
-    | Variable u, Variable v -> Max ((if u = v then [u] else [u;v]),[])
-    | Variable u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
-    | Max (gel,gtl), Variable v -> Max (list_add_set v gel,gtl)
+    | Atom u, Atom v -> if u = v then Atom u else Max ([u;v],[])
+    | u, Max ([],[]) -> u
+    | Max ([],[]), v -> v
+    | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
+    | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl)
     | Max (gel,gtl), Max (gel',gtl') ->
-	Max (list_union gel gel',list_union gtl gtl')
+	let gel'' = list_union gel gel' in
+	let gtl'' = list_union gtl gtl' in
+	Max (list_subtract gel'' gtl'',gtl'')
+
+let sup_array ls = Array.fold_right sup ls (Max ([],[]))
 
 (* Comparison on this type is pointer equality *)
 type canonical_arc =
-    { univ: universe_level; gt: universe_level list; ge: universe_level list }
+    { univ: universe_level; lt: universe_level list; le: universe_level list }
 
-let terminal u = {univ=u; gt=[]; ge=[]}
+let terminal u = {univ=u; lt=[]; le=[]}
 
-(* A universe is either an alias for another one, or a canonical one,
-   for which we know the universes that are smaller *)
+(* A universe_level is either an alias for another one, or a canonical one,
+   for which we know the universes that are above *)
 type univ_entry =
     Canonical of canonical_arc
   | Equiv of universe_level * universe_level
@@ -111,15 +122,23 @@ let declare_univ u g =
   else
     g
 
-(* When typing Prop and Set, there is no constraint on the level,
-   hence the definition of prop_univ *)
+(* The level of Set *)
+let base_univ = Atom Base
+
+let is_base = function
+  | Atom Base -> true
+  | Max ([Base],[]) -> warning "Non canonical Set"; true
+  | u -> false
+
+(* When typing [Prop] and [Set], there is no constraint on the level,
+   hence the definition of [prop_univ], the type of [Prop] *)
 
 let initial_universes = UniverseMap.empty
-let prop_univ = Max ([],[])
+let prop_univ = Max ([],[Base])
 
-(* Every universe has a unique canonical arc representative *)
+(* Every universe_level has a unique canonical arc representative *)
 
-(* repr : universes -> universe -> canonical_arc *)
+(* repr : universes -> universe_level -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
 let repr g u = 
   let rec repr_rec u =
@@ -136,30 +155,30 @@ let repr g u =
 
 let can g = List.map (repr g)
 
-(* transitive closure : we follow the Greater links *)
+(* transitive closure : we follow the Less links *)
 
 (* collect : canonical_arc -> canonical_arc list * canonical_arc list *)
-(* collect u = (V,W) iff V={v canonical | u>v} W={w canonical | u>=w}-V *)
-(* i.e. collect does the transitive closure of what is known about u *)
-let collect g arcu = 
-  let rec coll_rec gt ge = function
-    | [],[] -> (gt, list_subtractq ge gt)
-    | arcv::gt', ge' ->
-	if List.memq arcv gt then 
-	  coll_rec gt ge (gt',ge')
+(* collect u = (V,W) iff V={v canonical | u<v} W={w canonical | u<=w}-V *)
+(* i.e. collect does the transitive upward closure of what is known about u *)
+let collect g arcu =
+  let rec coll_rec lt le = function
+    | [],[] -> (lt, list_subtractq le lt)
+    | arcv::lt', le' ->
+	if List.memq arcv lt then 
+	  coll_rec lt le (lt',le')
 	else
-          coll_rec (arcv::gt) ge ((can g (arcv.gt@arcv.ge))@gt',ge')
-    | [], arcw::ge' -> 
-	if (List.memq arcw gt) or (List.memq arcw ge) then 
-	  coll_rec gt ge ([],ge')
+          coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le')
+    | [], arcw::le' -> 
+	if (List.memq arcw lt) or (List.memq arcw le) then 
+	  coll_rec lt le ([],le')
 	else
-          coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge')
+          coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le')
   in 
   coll_rec [] [] ([],[arcu])
 
-(* reprgeq : canonical_arc -> canonical_arc list *)
-(* All canonical arcv such that arcu>=arcc with arcv#arcu *)
-let reprgeq g arcu =
+(* reprleq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
+let reprleq g arcu =
   let rec searchrec w = function
     | [] -> w
     | v :: vl ->
@@ -169,17 +188,17 @@ let reprgeq g arcu =
         else 
 	  searchrec (arcv :: w) vl
   in 
-  searchrec [] arcu.ge
+  searchrec [] arcu.le
 
 
-(* between : universe -> canonical_arc -> canonical_arc list *)
-(* between u v = {w|u>=w>=v, w canonical}          *)     
+(* between : universe_level -> canonical_arc -> canonical_arc list *)
+(* between u v = {w|u<=w<=v, w canonical}          *)     
 (* between is the most costly operation *)
 
 let between g u arcv = 
-  (* good are all w | u >= w >= v  *)
-  (* bad are all w | u >= w ~>= v *)
-    (* find good and bad nodes in {w | u >= w} *)
+  (* good are all w | u <= w <= v  *)
+  (* bad are all w | u <= w ~<= v *)
+    (* find good and bad nodes in {w | u <= w} *)
     (* explore b u = (b or "u is good") *)
   let rec explore ((good, bad, b) as input) arcu =
     if List.memq arcu good then
@@ -187,12 +206,12 @@ let between g u arcv =
     else if List.memq arcu bad then
       input    (* (good, bad, b or false) *)
     else 
-      let childs = reprgeq g arcu in 
-	(* are any children of u good ? *)
-      let good, bad, b_childs = 
-	List.fold_left explore (good, bad, false) childs 
+      let leq = reprleq g arcu in 
+	(* is some universe >= u good ? *)
+      let good, bad, b_leq = 
+	List.fold_left explore (good, bad, false) leq
       in
-	if b_childs then
+	if b_leq then
 	  arcu::good, bad, true (* b or true *)
 	else 
 	  good, arcu::bad, b    (* b or false *)
@@ -200,64 +219,64 @@ let between g u arcv =
   let good,_,_ = explore ([arcv],[],false) (repr g u) in
     good
       
-(* We assume  compare(u,v) = GE with v canonical (see compare below).
+(* We assume  compare(u,v) = LE with v canonical (see compare below).
    In this case List.hd(between g u v) = repr u
    Otherwise, between g u v = [] 
  *)
 
 
-type order = EQ | GT | GE | NGE
+type order = EQ | LT | LE | NLE
 
-(* compare : universe -> universe -> order *)
+(* compare : universe_level -> universe_level -> order *)
 let compare g u v = 
   let arcu = repr g u 
   and arcv = repr g v in
   if arcu==arcv then 
     EQ
   else 
-    let (gt,geq) = collect g arcu in
-    if List.memq arcv gt then 
-      GT
-    else if List.memq arcv geq then 
-      GE
+    let (lt,leq) = collect g arcu in
+    if List.memq arcv lt then 
+      LT
+    else if List.memq arcv leq then 
+      LE
     else 
-      NGE
+      NLE
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
-                compare(u,v) = GT or GE => compare(v,u) = NGE
-                compare(u,v) = NGE => compare(v,u) = NGE or GE or GT
+                compare(u,v) = LT or LE => compare(v,u) = NLE
+                compare(u,v) = NLE => compare(v,u) = NLE or LE or LT
 
-   Adding u>=v is consistent iff compare(v,u) # GT 
-    and then it is redundant iff compare(u,v) # NGE
-   Adding u>v is consistent iff compare(v,u) = NGE 
-    and then it is redundant iff compare(u,v) = GT *)
+   Adding u>=v is consistent iff compare(v,u) # LT 
+    and then it is redundant iff compare(u,v) # NLE
+   Adding u>v is consistent iff compare(v,u) = NLE 
+    and then it is redundant iff compare(u,v) = LT *)
 
 
-(* setgt : universe -> universe -> unit *)
+(* setlt : universe_level -> universe_level -> unit *)
 (* forces u > v *)
-let setgt g u v =
+let setlt g u v =
   let arcu = repr g u in
-  enter_arc {arcu with gt=v::arcu.gt} g
+  enter_arc {arcu with lt=v::arcu.lt} g
 
-(* checks that non-redondant *)
-let setgt_if g u v = match compare g u v with
-  | GT -> g
-  | _ -> setgt g u v
+(* checks that non-redundant *)
+let setlt_if g u v = match compare g u v with
+  | LT -> g
+  | _ -> setlt g u v
 
-(* setgeq : universe -> universe -> unit *)
+(* setleq : universe_level -> universe_level -> unit *)
 (* forces u >= v *)
-let setgeq g u v =
+let setleq g u v =
   let arcu = repr g u in
-  enter_arc {arcu with ge=v::arcu.ge} g
+  enter_arc {arcu with le=v::arcu.le} g
 
 
-(* checks that non-redondant *)
-let setgeq_if g u v = match compare g u v with
-  | NGE -> setgeq g u v
+(* checks that non-redundant *)
+let setleq_if g u v = match compare g u v with
+  | NLE -> setleq g u v
   | _ -> g
 
-(* merge : universe -> universe -> unit *)
-(* we assume  compare(u,v) = GE *)
+(* merge : universe_level -> universe_level -> unit *)
+(* we assume  compare(u,v) = LE *)
 (* merge u v  forces u ~ v with repr u as canonical repr *)
 let merge g u v =
   match between g u (repr g v) with
@@ -265,23 +284,23 @@ let merge g u v =
                  (* redirected to it *)
 	let redirect (g,w,w') arcv =
  	  let g' = enter_equiv_arc arcv.univ arcu.univ g in
- 	  (g',list_unionq arcv.gt w,arcv.ge@w') 
+ 	  (g',list_unionq arcv.lt w,arcv.le@w') 
 	in
 	let (g',w,w') = List.fold_left redirect (g,[],[]) v in
-	let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' w in
-	let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' w' in
+	let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in
+	let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in
 	g'''
     | [] -> anomaly "Univ.between"
 
-(* merge_disc : universe -> universe -> unit *)
-(* we assume  compare(u,v) = compare(v,u) = NGE *)
+(* merge_disc : universe_level -> universe_level -> unit *)
+(* we assume  compare(u,v) = compare(v,u) = NLE *)
 (* merge_disc u v  forces u ~ v with repr u as canonical repr *)
 let merge_disc g u v =
   let arcu = repr g u in
   let arcv = repr g v in
   let g' = enter_equiv_arc arcv.univ arcu.univ g in
-  let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' arcv.gt in
-  let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' arcv.ge in
+  let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in
+  let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in
   g'''
 
 (* Universe inconsistency: error raised when trying to enforce a relation
@@ -291,55 +310,55 @@ exception UniverseInconsistency
 
 let error_inconsistency () = raise UniverseInconsistency
 
-(* enforcegeq : universe -> universe -> unit *)
-(* enforcegeq u v will force u>=v if possible, will fail otherwise *)
-let enforce_univ_geq u v g =
+(* enforce_univ_leq : universe_level -> universe_level -> unit *)
+(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
+let enforce_univ_leq u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
-    | NGE -> 
+    | NLE -> 
 	(match compare g v u with
-           | GT -> error_inconsistency()
-           | GE -> merge g v u
-           | NGE -> setgeq g u v
+           | LT -> error_inconsistency()
+           | LE -> merge g v u
+           | NLE -> setleq g u v
            | EQ -> anomaly "Univ.compare")
     | _ -> g
 
-(* enforceq : universe -> universe -> unit *)
-(* enforceq u v will force u=v if possible, will fail otherwise *)
+(* enforc_univ_eq : universe_level -> universe_level -> unit *)
+(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
 let enforce_univ_eq u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
     | EQ -> g
-    | GT -> error_inconsistency()
-    | GE -> merge g u v
-    | NGE -> 
+    | LT -> error_inconsistency()
+    | LE -> merge g u v
+    | NLE -> 
 	(match compare g v u with
-           | GT -> error_inconsistency()
-           | GE -> merge g v u
-           | NGE -> merge_disc g u v
+           | LT -> error_inconsistency()
+           | LE -> merge g v u
+           | NLE -> merge_disc g u v
            | EQ -> anomaly "Univ.compare")
 
-(* enforcegt u v will force u>v if possible, will fail otherwise *)
-let enforce_univ_gt u v g =
+(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
+let enforce_univ_lt u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
-    | GT -> g
-    | GE -> setgt g u v
+    | LT -> g
+    | LE -> setlt g u v
     | EQ -> error_inconsistency()
-    | NGE -> 
+    | NLE -> 
 	(match compare g v u with
-           | NGE -> setgt g u v
+           | NLE -> setlt g u v
            | _ -> error_inconsistency())
 
 (*
 let enforce_univ_relation g = function 
   | Equiv (u,v) -> enforce_univ_eq u v g
-  | Canonical {univ=u; gt=gt; ge=ge} ->
-      let g' = List.fold_right (enforce_univ_gt u) gt g in
-      List.fold_right (enforce_univ_geq u) ge g'
+  | Canonical {univ=u; lt=lt; le=le} ->
+      let g' = List.fold_right (enforce_univ_lt u) lt g in
+      List.fold_right (enforce_univ_leq u) le g'
 *)
 
 (* Merging 2 universe graphs *)
@@ -351,14 +370,14 @@ let merge_universes sp u1 u2 =
 
 (* Constraints and sets of consrtaints. *)
 
-type constraint_type = Gt | Geq | Eq
+type constraint_type = Lt | Leq | Eq
 
 type univ_constraint = universe_level * constraint_type * universe_level
 
 let enforce_constraint cst g =
   match cst with
-    | (u,Gt,v) -> enforce_univ_gt u v g
-    | (u,Geq,v) -> enforce_univ_geq u v g
+    | (u,Lt,v) -> enforce_univ_lt u v g
+    | (u,Leq,v) -> enforce_univ_leq u v g
     | (u,Eq,v) -> enforce_univ_eq u v g
 
 
@@ -373,25 +392,84 @@ type constraints = Constraint.t
 type constraint_function = 
     universe -> universe -> constraints -> constraints
 
-let enforce_gt u v c = Constraint.add (u,Gt,v) c
+let constraint_add_leq v u c =
+  if v = Base then c else Constraint.add (v,Leq,u) c
 
 let enforce_geq u v c =
-  match u with
-    | Variable u -> (match v with
-	| Variable v -> Constraint.add (u,Geq,v) c
-	| Max (l1, l2) ->
-	    let d = List.fold_right (fun v -> Constraint.add (u,Geq,v)) l1 c in
-	    List.fold_right (fun v -> Constraint.add (u,Gt,v)) l2 d) 
-    | Max _ -> anomaly "A universe bound can only be a variable"
+  match u, v with
+  | Atom u, Atom v -> constraint_add_leq v u c
+  | Atom u, Max (gel,gtl) ->
+      let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in
+      List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d
+  | _ -> anomaly "A universe bound can only be a variable"
 
 let enforce_eq u v c =
   match (u,v) with
-    | Variable u, Variable v -> Constraint.add (u,Eq,v) c
+    | Atom u, Atom v -> Constraint.add (u,Eq,v) c
     | _ -> anomaly "A universe comparison can only happen between variables"
 
 let merge_constraints c g =
   Constraint.fold enforce_constraint c g
 
+(**********************************************************************)
+(* Tools for sort-polymorphic inductive types                         *)
+
+(* Temporary inductive type levels *)
+
+let fresh_level =
+  let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n)
+
+let fresh_local_univ () = Atom (fresh_level ())
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur only in the le constraints *)
+
+let make_max = function
+  | ([u],[]) -> Atom u
+  | (le,lt) -> Max (le,lt)
+
+let remove_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_universe = function
+  | Max ([],[]) -> true
+  | _ -> false
+
+let is_direct_constraint u = function
+  | Atom u' -> u = u'
+  | Max (le,lt) -> List.mem u le
+
+(* 
+   Solve a system of universe constraint of the form
+
+   u_s11, ..., u_s1p1, w1 <= u1
+   ...
+   u_sn1, ..., u_snpn, wn <= un
+
+where 
+
+  - the ui (1 <= i <= n) are universe variables,
+  - the sjk select subsets of the ui for each equations, 
+  - the wi are arbitrary complex universes that do not mention the ui.
+*)
+
+let solve_constraints_system levels level_bounds =
+  let levels = 
+    Array.map (function Atom u -> u | _ -> anomaly "expects Atom") levels in
+  let v = Array.copy level_bounds in
+  let nind = Array.length v in
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if i<>j & is_direct_constraint levels.(j) v.(i) then
+	v.(i) <- sup v.(i) v.(j)
+    done;
+    for j=0 to nind-1 do
+      v.(i) <- remove_constraint levels.(j) v.(i)
+    done
+  done;
+  v
+
 (* Pretty-printing *)
 
 let num_universes g =
@@ -400,19 +478,19 @@ let num_universes g =
 let num_edges g =
   let reln_len = function
     | Equiv _ -> 1
-    | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge
+    | Canonical {lt=lt;le=le} -> List.length lt + List.length le
   in
   UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0
     
 let pr_arc = function 
-  | Canonical {univ=u; gt=[]; ge=[]} ->
+  | Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
-  | Canonical {univ=u; gt=gt; ge=ge} ->
+  | Canonical {univ=u; lt=lt; le=le} ->
       pr_uni_level u ++ str " " ++
       v 0
-        (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++
-	(if ge <> [] & gt <> [] then spc () else mt ()) ++
-         prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++
+        (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++
+	 (if lt <> [] & le <> [] then spc () else mt()) ++
+         prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++
       fnl ()
   | Equiv (u,v) -> 
       pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
@@ -426,44 +504,48 @@ let pr_universes g =
 
 let dump_universes output g = 
   let dump_arc _ = function
-    | Canonical {univ=u; gt=gt; ge=ge} -> 
+    | Canonical {univ=u; lt=lt; le=le} -> 
 	let u_str = string_of_univ_level u in
 	  List.iter 
 	    (fun v -> 
 	       Printf.fprintf output "%s > %s ;\n" u_str
 		 (string_of_univ_level v)) 
-	    gt;
+	    lt;
 	  List.iter 
 	    (fun v -> 
 	       Printf.fprintf output "%s >= %s ;\n" u_str
 		 (string_of_univ_level v)) 
-	    ge
+	    le
     | Equiv (u,v) ->
 	Printf.fprintf output "%s = %s ;\n"
 	  (string_of_univ_level u) (string_of_univ_level v)
   in
     UniverseMap.iter dump_arc g 
 
+(* Hash-consing *)
+
 module Huniv =
   Hashcons.Make(
     struct
       type t = universe
       type u = Names.dir_path -> Names.dir_path
-      let hash_aux hdir u = { u with u_mod=hdir u.u_mod }
+      let hash_aux hdir = function
+	| Base -> Base
+	| Level (d,n) -> Level (hdir d,n)
       let hash_sub hdir = function
-	| Variable u -> Variable (hash_aux hdir u)
+	| Atom u -> Atom (hash_aux hdir u)
 	| Max (gel,gtl) ->
 	    Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
       let equal u v =
 	match u, v with
-	  | Variable u, Variable v -> u == v
+	  | Atom u, Atom v -> u == v
 	  | Max (gel,gtl), Max (gel',gtl') ->
-	      (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl')
+	      (list_for_all2eq (==) gel gel') &&
+              (list_for_all2eq (==) gtl gtl')
 	  | _ -> false
       let hash = Hashtbl.hash
     end)
 
 let hcons1_univ u =
-  let _,hdir,_,_,_ = Names.hcons_names() in
+  let _,_,hdir,_,_,_ = Names.hcons_names() in
   Hashcons.simple_hcons Huniv.f hdir u
-
diff --git a/kernel/univ.mli b/kernel/univ.mli
index e15971eb..f39f05d9 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -6,20 +6,27 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli,v 1.21.14.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+(*i $Id: univ.mli 8673 2006-03-29 21:21:52Z herbelin $ i*)
 
 (* Universes. *)
 
 type universe
 
+val base_univ : universe
 val prop_univ : universe
 val make_univ : Names.dir_path * int -> universe
 
+val is_base : universe -> bool
+
 (* The type of a universe *)
 val super : universe -> universe
+
 (* The max of 2 universes *)
 val sup   : universe -> universe -> universe
 
+(* The max of an array of universes *)
+val sup_array : universe array -> universe
+
 (*s Graphs of universes. *)
 
 type universes
@@ -47,13 +54,20 @@ exception UniverseInconsistency
 
 val merge_constraints : constraints -> universes -> universes
 
+(*s Support for sort-polymorphic inductive types *)
+
+val fresh_local_univ : unit -> universe
+
+val solve_constraints_system : universe array -> universe array -> 
+  universe array
+
+val is_empty_universe : universe -> bool
+
 (*s Pretty-printing of universes. *)
 
 val pr_uni : universe -> Pp.std_ppcmds
 val pr_universes : universes -> Pp.std_ppcmds
 
-val string_of_univ : universe -> string
-
 (*s Dumping to a file *)
 
 val dump_universes : out_channel -> universes -> unit
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
new file mode 100644
index 00000000..f038c04f
--- /dev/null
+++ b/kernel/vconv.ml
@@ -0,0 +1,555 @@
+open Names
+open Declarations
+open Term
+open Environ
+open Conv_oracle
+open Reduction 
+open Closure
+open Vm
+open Csymtable 
+open Univ
+
+let val_of_constr env c =
+  val_of_constr (pre_env env) c
+
+(* Test la structure des piles *)
+
+let compare_zipper z1 z2 =
+  match z1, z2 with
+  | Zapp args1, Zapp args2 -> nargs args1 = nargs args2
+  | Zfix _, Zfix _ -> true 
+  | Zswitch _, Zswitch _ -> true
+  | _ , _ -> false
+
+let rec compare_stack stk1 stk2 =
+  match stk1, stk2 with
+  | [], [] -> true
+  | z1::stk1, z2::stk2 ->
+      if compare_zipper z1 z2 then compare_stack stk1 stk2
+      else false
+  | _, _ -> false 
+
+(* Conversion *)
+let conv_vect fconv vect1 vect2 cu =
+  let n = Array.length vect1 in
+  if n = Array.length vect2 then
+    let rcu = ref cu in
+    for i = 0 to n - 1 do
+      rcu := fconv vect1.(i) vect2.(i) !rcu
+    done;
+    !rcu
+  else raise NotConvertible
+
+let infos = ref (create_clos_infos betaiotazeta Environ.empty_env)
+
+let rec conv_val pb k v1 v2 cu =
+  if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu 
+    
+and conv_whd pb k whd1 whd2 cu =  
+  match whd1, whd2 with
+  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu 
+  | Vprod p1, Vprod p2 ->
+      let cu = conv_val CONV k (dom p1) (dom p2) cu in
+      conv_fun pb k (codom p1) (codom p2) cu
+  | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu
+  | Vfix f1, Vfix f2 -> conv_fix k f1 f2 cu
+  | Vfix_app fa1, Vfix_app fa2 ->
+      let f1 = fix fa1 in
+      let args1 = args_of_fix fa1 in
+      let f2 = fix fa2 in
+      let args2 = args_of_fix fa2 in
+      conv_arguments k args1 args2 (conv_fix k f1 f2 cu)
+  | Vcofix cf1, Vcofix cf2 -> 
+      conv_cofix k cf1 cf2 cu
+  | Vcofix_app cfa1, Vcofix_app cfa2 ->	
+      let cf1 = cofix cfa1 in
+      let args1 = args_of_cofix cfa1 in
+      let cf2 = cofix cfa2 in
+      let args2 = args_of_cofix cfa2 in
+      conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu)
+  | Vconstr_const i1, Vconstr_const i2 -> 
+      if i1 = i2 then cu else raise NotConvertible 
+  | Vconstr_block b1, Vconstr_block b2 ->
+      let sz = bsize b1 in
+      if btag b1 = btag b2 && sz = bsize b2 then
+	let rcu = ref cu in
+	for i = 0 to sz - 1 do
+	  rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu
+	done;
+	!rcu
+      else raise NotConvertible
+  | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> 
+      conv_atom pb k a1 stk1 a2 stk2 cu
+  | _, Vatom_stk(Aiddef(_,v),stk) -> 
+      conv_whd pb k whd1 (force_whd v stk) cu
+  | Vatom_stk(Aiddef(_,v),stk), _ -> 
+      conv_whd pb k (force_whd v stk) whd2 cu
+  | _, _ -> raise NotConvertible
+
+and conv_atom pb k a1 stk1 a2 stk2 cu =
+  match a1, a2 with
+  | Aind (kn1,i1), Aind(kn2,i2) ->
+      if i1 = i2 && mind_equiv !infos kn1 kn2 && compare_stack stk1 stk2 then
+	conv_stack k stk1 stk2 cu
+      else raise NotConvertible
+  | Aid ik1, Aid ik2 -> 
+      if ik1 = ik2 && compare_stack stk1 stk2 then 
+	conv_stack k stk1 stk2 cu 
+      else raise NotConvertible
+  | Aiddef(ik1,v1), Aiddef(ik2,v2) ->
+      begin
+	try
+	  if ik1 = ik2 && compare_stack stk1 stk2 then
+	    conv_stack k stk1 stk2 cu 
+	  else raise NotConvertible
+	with NotConvertible ->
+	  if oracle_order ik1 ik2 then             
+            conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
+          else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
+      end
+  | Aiddef(ik1,v1), _ ->
+      conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
+  | _, Aiddef(ik2,v2) ->
+      conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
+  | Afix_app _, _ | _, Afix_app _ | Aswitch _, _ | _, Aswitch _ -> 
+      Util.anomaly "Vconv.conv_atom : Vm.whd_val doesn't work"
+  | _, _ -> raise NotConvertible 
+	
+and conv_stack k stk1 stk2 cu =
+  match stk1, stk2 with
+  | [], [] -> cu
+  | Zapp args1 :: stk1, Zapp args2 :: stk2 ->
+      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) 
+  | Zfix fa1 :: stk1, Zfix fa2 :: stk2 ->
+      let f1 = fix fa1 in
+      let args1 = args_of_fix fa1 in
+      let f2 = fix fa2 in
+      let args2 = args_of_fix fa2 in
+      conv_stack k stk1 stk2 
+	(conv_arguments k args1 args2 (conv_fix k f1 f2 cu))
+  | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 ->
+      if eq_tbl sw1 sw2 then
+	let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in
+	let rcu = ref (conv_val CONV k vt1 vt2 cu) in
+	let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in
+	for i = 0 to Array.length b1 - 1 do
+	  rcu := 
+	    conv_val CONV (k + fst b1.(i)) 
+	      (snd b1.(i)) (snd b2.(i)) !rcu
+	done;
+	conv_stack k stk1 stk2 !rcu
+      else raise NotConvertible
+  | _, _ -> raise NotConvertible
+
+and conv_fun pb k f1 f2 cu =
+  if f1 == f2 then cu
+  else
+    let arity,b1,b2 = decompose_vfun2 k f1 f2 in
+    conv_val pb (k+arity) b1 b2 cu
+
+and conv_fix k f1 f2 cu =
+  if f1 == f2 then cu 
+  else
+    if check_fix f1 f2 then
+      let tf1 = types_of_fix f1 in
+      let tf2 = types_of_fix f2 in
+      let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in
+      let bf1 = bodies_of_fix k f1 in
+      let bf2 = bodies_of_fix k f2 in
+      conv_vect (conv_fun CONV (k + (fix_ndef f1))) bf1 bf2 cu
+    else raise NotConvertible
+
+and conv_cofix k cf1 cf2 cu =
+  if cf1 == cf2 then cu
+  else
+    if check_cofix cf1 cf2 then
+      let tcf1 = types_of_cofix cf1 in
+      let tcf2 = types_of_cofix cf2 in
+      let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in
+      let bcf1 = bodies_of_cofix k cf1 in
+      let bcf2 = bodies_of_cofix k cf2 in
+      conv_vect (conv_val CONV (k + (cofix_ndef cf1))) bcf1 bcf2 cu
+    else raise NotConvertible
+
+and conv_arguments k args1 args2 cu =
+  if args1 == args2 then cu
+  else
+    let n = nargs args1 in
+    if n = nargs args2 then
+      let rcu = ref cu in
+      for i = 0 to n - 1 do
+	rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu
+      done;
+      !rcu
+    else raise NotConvertible
+
+let rec conv_eq pb t1 t2 cu =
+  if t1 == t2 then cu 
+  else
+    match kind_of_term t1, kind_of_term t2 with
+    | Rel n1, Rel n2 -> 
+	if n1 = n2 then cu else raise NotConvertible
+    | Meta m1, Meta m2 ->
+	if m1 = m2 then cu else raise NotConvertible
+    | Var id1, Var id2 -> 
+	if id1 = id2 then cu else raise NotConvertible
+    | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu
+    | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu
+    | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu
+    | Prod (_,t1,c1), Prod (_,t2,c2) -> 
+	conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
+	conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu)
+    | App (c1,l1), App (c2,l2) ->
+	conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu)
+    | Evar (e1,l1), Evar (e2,l2) ->
+	if e1 = e2 then conv_eq_vect l1 l2 cu
+	else raise NotConvertible
+    | Const c1, Const c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Ind c1, Ind c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Construct c1, Construct c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+	let pcu = conv_eq CONV p1 p2 cu in
+	let ccu = conv_eq CONV c1 c2 pcu in
+	conv_eq_vect bl1 bl2 ccu
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	else raise NotConvertible
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->	
+	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	else raise NotConvertible
+    | _ -> raise NotConvertible
+
+and conv_eq_vect vt1 vt2 cu =
+  let len = Array.length vt1 in
+  if len = Array.length vt2 then
+    let rcu = ref cu in
+    for i = 0 to len-1 do
+      rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu
+    done; !rcu
+  else raise NotConvertible
+      
+let vconv pb env t1 t2 =
+  let cu =
+    try conv_eq pb t1 t2 Constraint.empty
+    with NotConvertible ->
+      infos := create_clos_infos betaiotazeta env;
+      let v1 = val_of_constr env t1 in
+      let v2 = val_of_constr env t2 in
+      let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
+      cu
+  in cu
+    
+let _ = Reduction.set_vm_conv vconv
+
+let use_vm = ref false
+
+let set_use_vm b =
+  use_vm := b;
+  if b then Reduction.set_default_conv vconv
+  else Reduction.set_default_conv Reduction.conv_cmp
+      
+let use_vm _ = !use_vm
+
+(*******************************************)
+(* Calcul de la forme normal d'un terme    *)
+(*******************************************)
+
+let crazy_type = mkSet 
+
+let decompose_prod env t =
+  let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+  if name = Anonymous then (Name (id_of_string "x"),dom,codom)
+  else res
+
+exception Find_at of int
+
+(* rend le numero du constructeur correspondant au tag [tag],
+   [cst] = true si c'est un constructeur constant *)
+
+let invert_tag cst tag reloc_tbl =
+  try 
+    for j = 0 to Array.length reloc_tbl - 1 do
+      let tagj,arity = reloc_tbl.(j) in
+      if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then
+	raise (Find_at j)
+      else ()
+    done;raise Not_found 
+  with Find_at j -> (j+1)   
+             (* Argggg, ces constructeurs de ... qui commencent a 1*)
+
+(* Build the substitution that replaces Rels by the appropriate 
+  inductives *)
+let ind_subst mind mib =
+  let ntypes = mib.mind_ntypes in
+  let make_Ik k = mkInd (mind,ntypes-k-1) in 
+  Util.list_tabulate make_Ik ntypes
+
+(* Instantiate inductives and parameters in constructor type
+   in normal form *)
+let constructor_instantiate mind mib params ctyp =
+  let si = ind_subst mind mib in
+  let ctyp1 = substl si ctyp in
+  let nparams = Array.length params in
+  if nparams = 0 then ctyp1
+  else
+    let _,ctyp2 = decompose_prod_n nparams ctyp1 in
+    let sp = List.rev (Array.to_list params) in substl sp ctyp2
+  
+let destApplication t =
+  try destApp t 
+  with _ -> t,[||]
+
+let construct_of_constr_const env tag typ =
+  let cind,params = destApplication (whd_betadeltaiota env typ) in
+  let ind = destInd cind in
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  let rtbl = mip.mind_reloc_tbl in
+  let i = invert_tag true tag rtbl in
+  mkApp(mkConstruct(ind,i), params)
+
+let find_rectype typ =
+  let cind,args = destApplication typ in
+  let ind = destInd cind in
+  ind, args
+
+let construct_of_constr_block env tag typ =
+  let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env typ) in
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let nparams = mib.mind_nparams in
+  let rtbl = mip.mind_reloc_tbl in
+  let i = invert_tag false tag rtbl in
+  let params = Array.sub allargs 0 nparams in
+  let specif = mip.mind_nf_lc in
+  let ctyp = constructor_instantiate mind mib params specif.(i-1) in
+  (mkApp(mkConstruct(ind,i), params), ctyp)
+  	
+let constr_type_of_idkey env idkey =
+  match idkey with
+  | ConstKey cst ->
+      let ty = (lookup_constant cst env).const_type in
+      mkConst cst, ty
+  | VarKey id -> 
+      let (_,_,ty) = lookup_named id env in 
+      mkVar id, ty
+  | RelKey i -> 
+      let n = (nb_rel env - i) in
+      let (_,_,ty) = lookup_rel n env in
+      mkRel n, lift n ty
+
+let type_of_ind env ind = 
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_nf_arity
+
+let build_branches_type (mind,_ as _ind) mib mip params dep p rtbl =
+  (* [build_one_branch i cty] construit le type de la ieme branche (commence
+     a 0) et les lambda correspondant aux realargs *)
+  let build_one_branch i cty =
+    let typi = constructor_instantiate mind mib params cty in
+    let decl,indapp = Term.decompose_prod typi in
+    let ind,cargs = find_rectype indapp in
+    let nparams = Array.length params in
+    let carity = snd (rtbl.(i)) in
+    let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
+    let codom = 
+      let papp = mkApp(p,crealargs) in
+      if dep then
+	let cstr = ith_constructor_of_inductive ind (i+1) in
+        let relargs = Array.init carity (fun i -> mkRel (carity-i)) in
+	let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in
+	mkApp(papp,[|dep_cstr|])
+      else papp
+    in 
+    decl, codom
+  in Array.mapi build_one_branch mip.mind_nf_lc
+
+(* La fonction de normalisation *)
+
+let rec nf_val env v t = nf_whd env (whd_val v) t 
+
+and nf_whd env whd typ =
+  match whd with
+  | Vsort s -> mkSort s
+  | Vprod p ->
+      let dom = nf_val env (dom p) crazy_type in
+      let name = Name (id_of_string "x") in
+      let vc = body_of_vfun (nb_rel env) (codom p) in
+      let codom = nf_val (push_rel (name,None,dom) env) vc crazy_type in      
+      mkProd(name,dom,codom)	  
+  | Vfun f -> nf_fun env f typ
+  | Vfix f -> nf_fix env f
+  | Vfix_app fa ->
+      let f = fix fa in
+      let vargs = args_of_fix fa in
+      let fd = nf_fix env f in
+      let (_,i),(_,ta,_) = destFix fd in
+      let t = ta.(i) in
+      let _, args = nf_args  env vargs t in
+      mkApp(fd,args)
+  | Vcofix cf -> nf_cofix env cf 
+  | Vcofix_app cfa -> 
+      let cf = cofix cfa in
+      let vargs = args_of_cofix cfa in
+      let cfd = nf_cofix env cf in
+      let i,(_,ta,_) = destCoFix cfd in
+      let t = ta.(i) in
+      let _, args = nf_args env vargs t in
+      mkApp(cfd,args) 
+  | Vconstr_const n -> construct_of_constr_const env n typ
+  | Vconstr_block b ->
+      let capp,ctyp = construct_of_constr_block env (btag b) typ in
+      let args = nf_bargs env b ctyp in
+      mkApp(capp,args)
+  | Vatom_stk(Aid idkey, stk) ->
+      let c,typ = constr_type_of_idkey env idkey in
+      nf_stk env c typ stk
+  | Vatom_stk(Aiddef(idkey,v), stk) ->
+      nf_whd env (whd_stack v stk) typ
+  | Vatom_stk(Aind ind, stk) ->
+      nf_stk env (mkInd ind) (type_of_ind env ind) stk 
+  | Vatom_stk(_,stk) -> assert false
+
+and nf_stk env c t stk  =
+  match stk with
+  | [] -> c
+  | Zapp vargs :: stk ->
+      let t, args = nf_args env vargs t in
+      nf_stk env (mkApp(c,args)) t stk 
+  | Zfix fa :: stk ->   
+      let f = fix fa in
+      let vargs = args_of_fix fa in
+      let fd = nf_fix env f in
+      let (_,i),(_,ta,_) = destFix fd in
+      let tf = ta.(i) in
+      let typ, args = nf_args env vargs tf in
+      let _,_,codom = decompose_prod env typ in
+      nf_stk env (mkApp(mkApp(fd,args),[|c|])) (subst1 c codom) stk
+  | Zswitch sw :: stk -> 
+      let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env t) in
+      let (mib,mip) = Inductive.lookup_mind_specif env ind in
+      let nparams = mib.mind_nparams in
+      let params,realargs = Util.array_chop nparams allargs in
+      (* calcul du predicat du case, 
+        [dep] indique si c'est un case dependant *)
+      let dep,p = 
+	let dep = ref false in
+	let rec nf_predicate env v pT =
+	  match whd_val v, kind_of_term pT with
+	  | Vfun f, Prod _ ->
+	      let k = nb_rel env in
+	      let vb = body_of_vfun k f in
+	      let name,dom,codom = decompose_prod env pT in
+	      let body = 
+		nf_predicate (push_rel (name,None,dom) env) vb codom in
+              mkLambda(name,dom,body)
+	  | Vfun f, _ ->
+	      dep := true;
+	      let k = nb_rel env in
+	      let vb = body_of_vfun k f in
+	      let name = Name (id_of_string "c") in
+	      let n = mip.mind_nrealargs in
+	      let rargs = Array.init n (fun i -> mkRel (n-i)) in
+	      let dom = mkApp(mkApp(mkInd ind,params),rargs) in
+	      let body = 
+		nf_val (push_rel (name,None,dom) env) vb crazy_type in
+	      mkLambda(name,dom,body)
+          | _, _ -> nf_val env v crazy_type
+	in 
+	let aux = 
+	  nf_predicate env (type_of_switch sw) 
+	    (hnf_prod_applist env mip.mind_nf_arity (Array.to_list params)) in
+	!dep,aux in
+      (* Calcul du type des branches *)
+      let btypes = 
+	build_branches_type ind mib mip params dep p mip.mind_reloc_tbl in
+      (* calcul des branches *)
+      let bsw = branch_of_switch (nb_rel env) sw in
+      let mkbranch i (n,v) =
+	let decl,codom = btypes.(i) in
+	let env = 
+	  List.fold_right 
+	    (fun (name,t) env -> push_rel (name,None,t) env) decl env in
+	let b = nf_val env v codom in
+	compose_lam decl b 
+      in 
+      let branchs = Array.mapi mkbranch bsw in
+      let tcase = 
+	if dep then mkApp(mkApp(p, params), [|c|])
+	else mkApp(p, params)
+      in
+      let ci = case_info sw in
+      nf_stk env (mkCase(ci, p, c, branchs)) tcase stk
+       
+and nf_args env vargs t =
+  let t = ref t in
+  let len = nargs vargs in
+  let targs = 
+    Array.init len 
+      (fun i ->
+	let _,dom,codom = decompose_prod env !t in
+	let c = nf_val env (arg vargs i) dom in
+	t := subst1 c codom; c) in
+  !t,targs
+
+and nf_bargs env b t =
+  let t = ref t in
+  let len = bsize b in
+  let args = Array.create len crazy_type in
+  for i = 0 to len - 1 do
+    let _,dom,codom = decompose_prod env !t in
+    let c = nf_val env (bfield b i) dom in
+    args.(i) <- c;
+    t := subst1 c codom
+  done;
+  args
+(*  Array.init len 
+    (fun i ->
+      let _,dom,codom = decompose_prod env !t in
+      let c = nf_val env (bfield b i) dom in
+      t := subst1 c codom; c) *) 
+
+and nf_fun env f typ =
+  let k = nb_rel env in
+  let vb = body_of_vfun k f in
+  let name,dom,codom = decompose_prod env typ in
+  let body = nf_val (push_rel (name,None,dom) env) vb codom in
+  mkLambda(name,dom,body)
+
+and nf_fix env f =
+  let init = fix_init f in
+  let rec_args = rec_args f in
+  let ndef = fix_ndef f in
+  let vt = types_of_fix f in
+  let ft = Array.map (fun v -> nf_val env v crazy_type) vt in
+  let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in
+  let k = nb_rel env in
+  let vb = bodies_of_fix k f in 
+  let env = push_rec_types (name,ft,ft) env in 
+  let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in
+  mkFix ((rec_args,init),(name,ft,fb))
+  
+and nf_cofix env cf =
+  let init = cofix_init cf in
+  let ndef = cofix_ndef cf in
+  let vt = types_of_cofix cf in
+  let cft = Array.map (fun v -> nf_val env v crazy_type) vt in
+  let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in
+  let k = nb_rel env in
+  let vb = bodies_of_cofix k cf in 
+  let env = push_rec_types (name,cft,cft) env in 
+  let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in
+  mkCoFix (init,(name,cft,cfb))
+  
+let cbv_vm env c t  =
+  let transp = transp_values () in
+  if not transp then set_transp_values true; 
+  let v = val_of_constr env c in
+  let c = nf_val env v t in
+  if not transp then set_transp_values false; 
+  c
+  
+
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
new file mode 100644
index 00000000..4aed5d05
--- /dev/null
+++ b/kernel/vconv.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Reduction
+(*i*)
+
+(***********************************************************************)
+(*s conversion functions *)
+val use_vm : unit -> bool
+val set_use_vm : bool -> unit
+val vconv : conv_pb -> types conversion_function
+
+(***********************************************************************)
+(*s Reduction functions *)
+val cbv_vm : env -> constr -> types -> constr
+
+
+
+
+
+val nf_val : env -> values -> types -> constr
+
+val nf_whd : env -> Vm.whd -> types -> constr
+
+val nf_stk : env -> constr -> types -> Vm.stack  -> constr
+       
+val nf_args : env -> Vm.arguments -> types ->  types * constr array
+
+val nf_bargs : env -> Vm.vblock -> types -> constr array
+
+val nf_fun : env -> Vm.vfun -> types -> constr
+
+val nf_fix : env -> Vm.vfix -> constr 
+  
+val nf_cofix : env -> Vm.vcofix -> constr
+
+  
diff --git a/kernel/vm.ml b/kernel/vm.ml
new file mode 100644
index 00000000..c8be979e
--- /dev/null
+++ b/kernel/vm.ml
@@ -0,0 +1,601 @@
+open Obj
+open Names
+open Term
+open Conv_oracle
+open Cbytecodes
+
+
+external set_drawinstr : unit -> unit = "coq_set_drawinstr"
+
+(******************************************)
+(* Fonctions en plus du module Obj ********)
+(******************************************)
+
+external offset_closure : t -> int -> t = "coq_offset_closure"
+external offset : t -> int = "coq_offset"
+let first o = (offset_closure o (offset o))
+let last o = (field o (size o - 1))
+
+let accu_tag = 0
+
+(*******************************************)
+(* Initalisation de la machine abstraite ***)
+(*******************************************)
+
+external init_vm : unit -> unit = "init_coq_vm"
+
+let _ = init_vm ()
+
+external transp_values : unit -> bool = "get_coq_transp_value"
+external set_transp_values : bool -> unit = "coq_set_transp_value"
+
+(*******************************************)
+(* Le code machine  ************************)
+(*******************************************)
+
+type tcode 
+let tcode_of_obj v = ((obj v):tcode)
+let fun_code v = tcode_of_obj (field (repr v) 0)
+
+external mkAccuCode : int -> tcode = "coq_makeaccu"
+external mkPopStopCode : int -> tcode = "coq_pushpop"
+external mkAccuCond : int -> tcode = "coq_accucond"
+
+external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode"
+external int_tcode : tcode -> int -> int = "coq_int_tcode"
+
+external accumulate : unit -> tcode = "accumulate_code"
+let accumulate = accumulate ()
+
+external is_accumulate : tcode -> bool = "coq_is_accumulate_code"
+
+let popstop_tbl =  ref (Array.init 30 mkPopStopCode) 
+
+let popstop_code i =
+  let len = Array.length !popstop_tbl in
+  if i < len then !popstop_tbl.(i) 
+  else
+    begin
+      popstop_tbl :=
+	Array.init (i+10)
+	  (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j);
+      !popstop_tbl.(i) 
+    end
+
+let stop = popstop_code 0
+  
+(******************************************************)
+(* Types de donnees abstraites et fonctions associees *)
+(******************************************************)
+
+(* Values of the abstract machine *)
+let val_of_obj v = ((obj v):values)
+let crasy_val = (val_of_obj (repr 0))
+
+
+(* Functions *)
+type vfun  
+(* v = [Tc | c | fv1 | ... | fvn ] *)
+(*         ^                       *)
+(* [Tc | (Restart : c) | v | a1 | ... an] *)
+(*              ^                         *)
+
+(* Products *)
+type vprod 
+(* [0 | dom : codom] *) 
+(*     ^              *)
+let dom : vprod -> values = fun p -> val_of_obj (field (repr p) 0) 
+let codom : vprod -> vfun = fun p -> (obj (field (repr p) 1))
+
+(* Arguments *)
+type arguments 
+(* arguments = [_ | _ | _ | a1 | ... | an] *)
+(*                ^                        *)
+let nargs : arguments -> int = fun args -> (size (repr args)) - 2
+
+let unsafe_arg : arguments -> int -> values =
+     fun args i ->  val_of_obj (field (repr args) (i+2))
+
+let arg args i = 
+  if  0 <= i && i < (nargs args) then unsafe_arg args i 
+  else raise (Invalid_argument 
+		("Vm.arg size = "^(string_of_int (nargs args))^
+		 " acces "^(string_of_int i)))
+
+(* Fixpoints *)
+type vfix
+
+(* [Tc|c0|Ti|c1|...|Ti|cn|fv1|...|fvn| [ct0|...|ctn]] *)
+(*          ^                                         *)
+type vfix_block 
+
+let fix_init : vfix -> int = fun vf -> (offset (repr vf)/2)
+
+let block_of_fix : vfix -> vfix_block = fun vf -> obj (first (repr vf))
+
+let fix_block_type : vfix_block -> tcode array =
+  fun fb -> (obj (last (repr fb)))
+
+let fix_block_ndef : vfix_block -> int = 
+  fun fb -> size (last (repr fb))
+
+let fix_ndef vf = fix_block_ndef (block_of_fix vf)
+
+let unsafe_fb_code : vfix_block -> int -> tcode =
+  fun fb i -> tcode_of_obj (field (repr fb) (2 * i))
+
+let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1
+  
+let rec_args vf =
+  let fb = block_of_fix vf in
+  let size = fix_block_ndef fb in
+  Array.init size (unsafe_rec_arg fb)
+
+exception FALSE
+
+let check_fix f1 f2 = 
+  let i1, i2 = fix_init f1, fix_init f2 in
+  (* Verification du point de depart *)
+    if i1 = i2 then
+      let fb1,fb2 = block_of_fix f1, block_of_fix f2 in
+      let n = fix_block_ndef fb1 in
+    (* Verification du nombre de definition *)
+      if n = fix_block_ndef fb2 then
+      (* Verification des arguments recursifs *)
+	try
+	  for i = 0 to n - 1 do
+	    if not (unsafe_rec_arg fb1 i = unsafe_rec_arg fb2 i) then
+	      raise FALSE
+	  done;
+	  true
+	with FALSE -> false
+      else false 
+    else false
+
+(* Partials applications of Fixpoints *)
+type vfix_app
+let fix : vfix_app -> vfix = 
+  fun vfa -> ((obj (field (repr vfa) 1)):vfix)
+let args_of_fix : vfix_app -> arguments =
+  fun vfa -> ((magic  vfa) : arguments)
+
+(* CoFixpoints *)
+type vcofix 
+type vcofix_block
+let cofix_init : vcofix -> int = fun vcf -> (offset (repr vcf)/2)
+
+let block_of_cofix : vcofix -> vcofix_block = fun vcf -> obj (first (repr vcf))
+
+let cofix_block_ndef : vcofix_block -> int = 
+  fun fb -> size (last (repr fb))
+
+let cofix_ndef vcf= cofix_block_ndef (block_of_cofix vcf)
+
+let cofix_block_type : vcofix_block -> tcode array =
+  fun cfb -> (obj (last (repr cfb)))
+
+let check_cofix cf1 cf2 = 
+  cofix_init cf1 = cofix_init cf2 &&
+  cofix_ndef cf1 = cofix_ndef cf2 
+
+let cofix_arity c = int_tcode c 1
+
+let unsafe_cfb_code : vcofix_block -> int -> tcode =
+  fun cfb i -> tcode_of_obj (field (repr cfb) (2 * i))
+
+(* Partials applications of CoFixpoints *)
+type vcofix_app 
+let cofix : vcofix_app -> vcofix = 
+  fun vcfa -> ((obj (field (repr vcfa) 1)):vcofix)
+let args_of_cofix : vcofix_app -> arguments = 
+  fun vcfa -> ((magic  vcfa) : arguments)
+
+(* Blocks *)
+type vblock (* la representation Ocaml *)
+let btag : vblock -> int = fun b -> tag (repr b)
+let bsize : vblock -> int = fun b -> size (repr b)
+let bfield b i =
+  if 0 <= i && i < (bsize b) then
+    val_of_obj (field (repr b) i)
+  else raise (Invalid_argument "Vm.bfield")
+
+(* Accumulators and atoms *)
+
+type accumulator 
+(* [Ta | accumulate | at | a1 | ... | an ] *)
+
+type inv_rel_key = int
+
+type id_key = inv_rel_key tableKey
+
+type vstack = values array
+
+type vm_env 
+
+type vswitch = {
+    sw_type_code : tcode; 
+    sw_code : tcode; 
+    sw_annot : annot_switch;
+    sw_stk : vstack;
+    sw_env : vm_env
+  } 
+
+(* Ne pas changer ce type sans modifier le code C *)
+type atom = 
+  | Aid of id_key
+  | Aiddef of id_key * values
+  | Aind of inductive
+  | Afix_app of accumulator * vfix_app
+  | Aswitch of accumulator * vswitch
+
+let atom_of_accu : accumulator -> atom =
+  fun a -> ((obj (field (repr a) 1)) : atom)
+
+let args_of_accu : accumulator -> arguments = 
+  fun a -> ((magic a) : arguments)
+
+let nargs_of_accu a = nargs (args_of_accu a)
+
+(* Les zippers *)
+
+type zipper =
+  | Zapp of arguments
+  | Zfix of vfix_app
+  | Zswitch of vswitch
+
+type stack = zipper list
+
+type whd =
+  | Vsort of sorts
+  | Vprod of vprod 
+  | Vfun of vfun
+  | Vfix of vfix
+  | Vfix_app of vfix_app
+  | Vcofix of vcofix
+  | Vcofix_app of vcofix_app
+  | Vconstr_const of int
+  | Vconstr_block of vblock
+  | Vatom_stk of atom * stack
+(* Les atomes sont forcement Aid Aiddef Aind *)
+
+(**********************************************)
+(* Constructeurs ******************************)
+(**********************************************)
+(* obj_of_atom : atom -> t *)
+let obj_of_atom : atom -> t =
+  fun a -> 
+    let res = Obj.new_block accu_tag 2 in
+    set_field res 0 (repr accumulate);
+    set_field res 1 (repr a);
+    res 
+
+(* obj_of_str_const : structured_constant -> t *)
+let rec obj_of_str_const str =
+  match str with 
+  | Const_sorts s -> repr (Vsort s)
+  | Const_ind ind -> obj_of_atom (Aind ind)
+  | Const_b0 tag -> repr tag
+  | Const_bn(tag, args) ->
+      let len = Array.length args in
+      let res = new_block tag len in
+      for i = 0 to len - 1 do 
+	set_field res i (obj_of_str_const args.(i)) 
+      done;
+      res
+
+let val_of_obj o = ((obj o) : values)
+
+let val_of_str_const str = val_of_obj (obj_of_str_const str)
+
+let val_of_atom a = val_of_obj (obj_of_atom a)
+
+let idkey_tbl = Hashtbl.create 31
+
+let val_of_idkey key =
+  try Hashtbl.find idkey_tbl key 
+  with Not_found -> 
+    let v = val_of_atom (Aid key) in
+    Hashtbl.add idkey_tbl key v;
+    v
+
+let val_of_rel k = val_of_idkey (RelKey k)
+let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v))
+
+let val_of_named id = val_of_idkey (VarKey id)
+let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v))
+  
+let val_of_constant c = val_of_idkey (ConstKey c)
+let val_of_constant_def n c v = 
+  let res = Obj.new_block accu_tag 2 in
+  set_field res 0 (repr (mkAccuCond n));
+  set_field res 1 (repr (Aiddef(ConstKey c, v)));
+  val_of_obj res 
+
+
+
+(*************************************************)
+(* Destructors ***********************************)
+(*************************************************)
+
+
+let rec whd_accu a stk =
+  let stk = 
+    if nargs_of_accu a = 0 then stk
+    else Zapp (args_of_accu a) :: stk in
+  let at = atom_of_accu a in 
+  match at with
+  | Aid _ | Aiddef _ | Aind _ -> Vatom_stk(at, stk)
+  | Afix_app(a,fa) -> whd_accu a (Zfix fa :: stk)
+  | Aswitch(a,sw) -> whd_accu a (Zswitch sw :: stk)
+
+external kind_of_closure : t -> int = "coq_kind_of_closure"
+
+let whd_val : values -> whd =
+  fun v -> 
+    let o = repr v in 
+    if is_int o then Vconstr_const (obj o)
+    else 
+      let tag = tag o in
+      if tag = accu_tag then
+	if is_accumulate (fun_code o) then whd_accu (obj o) []
+	else 
+	  if size o = 1 then Vsort(obj (field o 0))
+	  else Vprod(obj o)
+      else 
+	if tag = closure_tag || tag = infix_tag then
+	  match kind_of_closure o with
+	  | 0 -> Vfun(obj o)
+	  | 1 -> Vfix(obj o)
+	  | 2 -> Vfix_app(obj o) 
+	  | 3 -> Vcofix(obj o)
+	  | 4 -> Vcofix_app(obj o)
+	  | 5 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), [])
+	  | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work"
+	else Vconstr_block(obj o)
+	
+
+
+(************************************************)
+(* La machine abstraite *************************)
+(************************************************)
+
+
+(* gestion de la pile *)
+external push_ra : tcode -> unit = "coq_push_ra"
+external push_val : values -> unit = "coq_push_val"
+external push_arguments : arguments -> unit = "coq_push_arguments"
+external push_vstack : vstack -> unit = "coq_push_vstack"
+
+
+(* interpreteur *)
+external interprete : tcode -> values -> vm_env -> int -> values =
+  "coq_interprete_ml"
+
+let apply_arguments vf vargs =
+  let n = nargs vargs in
+  if n = 0 then vf 
+  else
+   begin
+     push_ra stop;
+     push_arguments vargs;
+     interprete (fun_code vf) vf (magic vf) (n - 1)
+   end
+
+let apply_vstack vf vstk =
+  let n = Array.length vstk in
+  if n = 0 then vf
+  else 
+    begin
+      push_ra stop;
+      push_vstack vstk;
+      interprete (fun_code vf) vf (magic vf) (n - 1)
+    end
+
+let apply_fix_app vfa arg =
+  let vf = fix vfa in
+  let vargs = args_of_fix vfa in
+  push_ra stop;
+  push_val arg;
+  push_arguments vargs;
+  interprete (fun_code vf) (magic vf) (magic vf) (nargs vargs)
+
+external set_forcable : unit -> unit = "coq_set_forcable"
+let force_cofix v =
+  match whd_val v with
+  | Vcofix _    | Vcofix_app _ ->
+      push_ra stop;
+      set_forcable ();
+      interprete (fun_code v) (magic v) (magic v) 0
+  | _ -> v
+  
+let apply_switch sw arg =
+  let arg = force_cofix arg in
+  let tc = sw.sw_annot.tailcall in
+  if tc then 
+    (push_ra stop;push_vstack sw.sw_stk)
+  else 
+    (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk)));
+  interprete sw.sw_code arg sw.sw_env 0
+
+let is_accu v = 
+  is_block (repr v) && tag (repr v) = accu_tag && 
+  fun_code v == accumulate 
+
+let rec whd_stack v stk =  
+  match stk with
+  | [] -> whd_val v
+  | Zapp a :: stkt -> whd_stack (apply_arguments v a) stkt
+  | Zfix fa :: stkt -> 
+      if is_accu v then whd_accu (magic v) stk
+      else whd_stack (apply_fix_app fa v) stkt
+  | Zswitch sw :: stkt -> 
+      if is_accu v then whd_accu (magic v) stk 
+      else whd_stack (apply_switch sw v) stkt 
+
+let rec force_whd v stk =
+  match whd_stack v stk with
+  | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk
+  | res -> res
+
+	  
+
+(* Function *)
+external closure_arity : vfun -> int = "coq_closure_arity"
+
+(* [apply_rel v k arity] applique la valeurs [v] aux arguments 
+   [k],[k+1], ... , [k+arity-1] *)
+let mkrel_vstack k arity =
+  let max = k + arity - 1 in
+  Array.init arity (fun i -> val_of_rel (max - i))
+
+let body_of_vfun k vf =
+  let vargs = mkrel_vstack k 1 in
+  apply_vstack (magic vf) vargs
+
+let decompose_vfun2 k vf1 vf2 =
+  let arity = min (closure_arity vf1) (closure_arity vf2) in
+  assert (0 <= arity && arity < Sys.max_array_length);
+  let vargs = mkrel_vstack k arity in
+  let v1 = apply_vstack (magic vf1) vargs in
+  let v2 = apply_vstack (magic vf2) vargs in
+  arity, v1, v2
+    
+  
+(* Fix *)
+external atom_rel : unit -> atom array = "get_coq_atom_tbl"
+external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl"
+
+let relaccu_tbl =  
+  let atom_rel = atom_rel() in
+  let len = Array.length atom_rel in
+  for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done;
+  ref (Array.init len mkAccuCode) 
+
+let relaccu_code i =
+  let len = Array.length !relaccu_tbl in
+  if i < len then !relaccu_tbl.(i) 
+  else
+    begin
+      realloc_atom_rel i;
+      let atom_rel = atom_rel () in
+      let nl = Array.length atom_rel in
+      for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done;
+      relaccu_tbl :=
+	Array.init nl
+	  (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j);
+      !relaccu_tbl.(i) 
+    end
+
+let jump_grabrec c = offset_tcode c 2
+let jump_grabrecrestart c = offset_tcode c 3
+
+let bodies_of_fix k vf = 
+  let fb = block_of_fix vf in
+  let ndef = fix_block_ndef fb in
+  (* Construction de l' environnement des corps des points fixes *)
+  let e = dup (repr fb) in
+  for i = 0 to ndef - 1 do
+    set_field e (2 * i) (repr (relaccu_code (k + i)))
+  done;
+  let fix_body i =
+    let c = jump_grabrec (unsafe_fb_code fb i)  in
+    let res = Obj.new_block closure_tag 2 in
+    set_field res 0 (repr c);
+    set_field res 1 (offset_closure e (2*i));
+    ((obj res) : vfun)
+  in Array.init ndef fix_body
+ 
+let types_of_fix vf =
+  let fb = block_of_fix vf in
+  let type_code = fix_block_type fb in
+  let type_val c = interprete c crasy_val (magic fb) 0 in
+  Array.map type_val type_code
+
+ 
+(* CoFix *)
+let jump_cograb c = offset_tcode c 2
+let jump_cograbrestart c = offset_tcode c 3 
+
+let bodies_of_cofix k vcf =
+  let cfb = block_of_cofix vcf in
+  let ndef = cofix_block_ndef cfb in
+  (* Construction de l' environnement des corps des cofix *)
+  let e = dup (repr cfb) in
+  for i = 0 to ndef - 1 do
+    set_field e (2 * i) (repr (relaccu_code (k + i)))
+  done;
+  let cofix_body i =
+    let c = unsafe_cfb_code cfb i in 
+    let arity = int_tcode c 1 in
+    if arity = 0 then 
+      begin
+	push_ra stop;
+	interprete (jump_cograbrestart c) crasy_val 
+	  (obj (offset_closure e (2*i))) 0
+      end
+    else 
+      let res = Obj.new_block closure_tag 2 in
+      set_field res 0 (repr (jump_cograb c));
+      set_field res 1 (offset_closure e (2*i));
+      ((obj res) : values)
+  in Array.init ndef cofix_body
+
+let types_of_cofix vcf =
+  let cfb = block_of_cofix vcf in
+  let type_code = cofix_block_type cfb in
+  let type_val c = interprete c crasy_val (magic cfb) 0 in
+  Array.map type_val type_code
+
+(* Switch *)
+      
+let eq_tbl sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl 
+    
+let case_info sw = sw.sw_annot.ci
+    
+let type_of_switch sw = 
+  push_vstack sw.sw_stk;
+  interprete sw.sw_type_code crasy_val sw.sw_env 0 
+    
+let branch_arg k (tag,arity) = 
+  if arity = 0 then  ((magic tag):values)
+  else
+    let b = new_block tag arity in
+    for i = 0 to arity - 1 do
+      set_field b i (repr (val_of_rel (k+i)))
+    done;
+    val_of_obj b
+  
+      
+let branch_of_switch k sw =
+  let eval_branch (_,arity as ta) =
+    let arg = branch_arg k ta in
+    let v = apply_switch sw arg in
+    (arity, v)
+  in 
+  Array.map eval_branch sw.sw_annot.rtbl
+    
+
+    
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/kernel/vm.mli b/kernel/vm.mli
new file mode 100644
index 00000000..b5fd9b9d
--- /dev/null
+++ b/kernel/vm.mli
@@ -0,0 +1,109 @@
+open Names
+open Term
+open Cbytecodes
+open Cemitcodes
+
+
+val set_drawinstr : unit -> unit
+
+val transp_values : unit -> bool
+val set_transp_values : bool -> unit
+(* le code machine *)
+type tcode 
+
+(* Les valeurs ***********)
+
+type accumulator
+type vprod 
+type vfun
+type vfix
+type vfix_app
+type vcofix
+type vcofix_app 
+type vblock
+type vswitch
+type arguments
+
+type zipper =
+  | Zapp of arguments
+  | Zfix of vfix_app
+  | Zswitch of vswitch
+
+type stack = zipper list
+
+
+type atom = 
+  | Aid of id_key
+  | Aiddef of id_key * values
+  | Aind of inductive
+  | Afix_app of accumulator * vfix_app
+  | Aswitch of accumulator * vswitch
+
+type whd =
+  | Vsort of sorts
+  | Vprod of vprod 
+  | Vfun of vfun
+  | Vfix of vfix
+  | Vfix_app of vfix_app
+  | Vcofix of vcofix
+  | Vcofix_app of vcofix_app
+  | Vconstr_const of int
+  | Vconstr_block of vblock
+  | Vatom_stk of atom * stack
+
+(* Constructors *)
+val val_of_str_const : structured_constant -> values
+
+val val_of_rel : int -> values 
+val val_of_rel_def : int -> values -> values 
+
+val val_of_named : identifier -> values
+val val_of_named_def : identifier -> values -> values
+
+val val_of_constant : constant -> values 
+val val_of_constant_def : int -> constant -> values -> values
+
+(* Destructors *)
+val whd_val : values -> whd
+
+(* Product *)
+val dom : vprod -> values
+val codom : vprod -> vfun
+(* Function *)
+val body_of_vfun : int -> vfun -> values 
+val decompose_vfun2  : int -> vfun -> vfun -> int * values * values
+(* Fix *)
+val fix : vfix_app -> vfix
+val args_of_fix : vfix_app -> arguments
+val fix_init : vfix -> int
+val fix_ndef : vfix -> int 
+val rec_args : vfix -> int array 
+val check_fix : vfix -> vfix -> bool
+val bodies_of_fix : int -> vfix -> vfun array
+val types_of_fix : vfix -> values array
+(* CoFix *)
+val cofix : vcofix_app -> vcofix
+val args_of_cofix : vcofix_app -> arguments
+val cofix_init : vcofix -> int 
+val cofix_ndef : vcofix -> int
+val check_cofix : vcofix -> vcofix -> bool
+val bodies_of_cofix : int -> vcofix -> values array
+val types_of_cofix : vcofix -> values array
+(* Block *)
+val btag : vblock -> int
+val bsize : vblock -> int
+val bfield : vblock -> int -> values
+(* Switch *)
+val eq_tbl : vswitch -> vswitch -> bool
+val case_info : vswitch -> case_info
+val type_of_switch : vswitch -> values
+val branch_of_switch : int -> vswitch -> (int * values) array
+(* Arguments *)  
+val nargs : arguments -> int
+val arg : arguments -> int -> values
+
+(* Evaluation *)
+val whd_stack : values -> stack -> whd
+val force_whd : values -> stack -> whd
+
+