added the .vo checker (with independent Makefile)

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@10826 85f007b7-540e-0410-9357-904b9bb8a0f7

33 files changed, 8418 insertions, 0 deletions

diff --git a/checker/.depend b/checker/.depend
new file mode 100644
index 000000000..d9c48a282
--- /dev/null
+++ b/checker/.depend
@@ -0,0 +1,120 @@
+checker.cmo: ../lib/util.cmi univ.cmi type_errors.cmi \
+    /usr/lib/ocaml/camlp4/token.cmi ../kernel/term.cmi ../lib/system.cmi \
+    /usr/lib/ocaml/camlp4/stdpp.cmi safe_typing.cmi ../lib/pp.cmi \
+    ../kernel/names.cmi indtypes.cmi ../lib/flags.cmi declarations.cmi \
+    ../config/coq_config.cmi check_stat.cmi check.cmo 
+checker.cmx: ../lib/util.cmx univ.cmx type_errors.cmx \
+    /usr/lib/ocaml/camlp4/token.cmi ../kernel/term.cmx ../lib/system.cmx \
+    /usr/lib/ocaml/camlp4/stdpp.cmi safe_typing.cmx ../lib/pp.cmi \
+    ../kernel/names.cmx indtypes.cmx ../lib/flags.cmx declarations.cmx \
+    ../config/coq_config.cmx check_stat.cmx check.cmx 
+check.cmo: ../lib/util.cmi ../lib/system.cmi safe_typing.cmi ../lib/pp.cmi \
+    ../kernel/names.cmi ../lib/flags.cmi 
+check.cmx: ../lib/util.cmx ../lib/system.cmx safe_typing.cmx ../lib/pp.cmi \
+    ../kernel/names.cmx ../lib/flags.cmx 
+check_stat.cmo: ../lib/util.cmi ../kernel/term.cmi ../lib/system.cmi \
+    safe_typing.cmi ../lib/pp.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    declarations.cmi check_stat.cmi 
+check_stat.cmx: ../lib/util.cmx ../kernel/term.cmx ../lib/system.cmx \
+    safe_typing.cmx ../lib/pp.cmi ../kernel/names.cmx ../kernel/environ.cmx \
+    declarations.cmx check_stat.cmi 
+closure.cmo: ../lib/util.cmi ../kernel/term.cmi ../lib/pp.cmi \
+    ../kernel/names.cmi esubst.cmi ../kernel/environ.cmi closure.cmi 
+closure.cmx: ../lib/util.cmx ../kernel/term.cmx ../lib/pp.cmi \
+    ../kernel/names.cmx esubst.cmx ../kernel/environ.cmx closure.cmi 
+closure.cmi: ../kernel/term.cmi ../lib/pp.cmi ../kernel/names.cmi esubst.cmi \
+    ../kernel/environ.cmi 
+declarations.cmo: ../lib/util.cmi univ.cmi ../kernel/term.cmi \
+    ../lib/rtree.cmi ../lib/option.cmi ../kernel/names.cmi declarations.cmi 
+declarations.cmx: ../lib/util.cmx univ.cmx ../kernel/term.cmx \
+    ../lib/rtree.cmx ../lib/option.cmx ../kernel/names.cmx declarations.cmi 
+declarations.cmi: ../lib/util.cmi univ.cmi ../kernel/term.cmi \
+    ../lib/rtree.cmi ../kernel/names.cmi 
+environ.cmo: ../lib/util.cmi univ.cmi ../kernel/term.cmi ../kernel/names.cmi \
+    declarations.cmi 
+environ.cmx: ../lib/util.cmx univ.cmx ../kernel/term.cmx ../kernel/names.cmx \
+    declarations.cmx 
+esubst.cmo: ../lib/util.cmi esubst.cmi 
+esubst.cmx: ../lib/util.cmx esubst.cmi 
+esubst.cmi: ../lib/util.cmi 
+indtypes.cmo: ../lib/util.cmi univ.cmi typeops.cmi ../kernel/term.cmi \
+    ../lib/rtree.cmi reduction.cmi ../lib/pp.cmi ../kernel/names.cmi \
+    inductive.cmi ../lib/flags.cmi ../kernel/environ.cmi declarations.cmi \
+    indtypes.cmi 
+indtypes.cmx: ../lib/util.cmx univ.cmx typeops.cmx ../kernel/term.cmx \
+    ../lib/rtree.cmx reduction.cmx ../lib/pp.cmi ../kernel/names.cmx \
+    inductive.cmx ../lib/flags.cmx ../kernel/environ.cmx declarations.cmx \
+    indtypes.cmi 
+indtypes.cmi: univ.cmi typeops.cmi ../kernel/term.cmi ../kernel/names.cmi \
+    ../kernel/environ.cmi declarations.cmi 
+inductive.cmo: ../lib/util.cmi univ.cmi type_errors.cmi ../kernel/term.cmi \
+    ../lib/rtree.cmi reduction.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    declarations.cmi inductive.cmi 
+inductive.cmx: ../lib/util.cmx univ.cmx type_errors.cmx ../kernel/term.cmx \
+    ../lib/rtree.cmx reduction.cmx ../kernel/names.cmx ../kernel/environ.cmx \
+    declarations.cmx inductive.cmi 
+inductive.cmi: univ.cmi ../kernel/term.cmi ../kernel/names.cmi \
+    ../kernel/environ.cmi declarations.cmi 
+main.cmo: checker.cmo 
+main.cmx: checker.cmx 
+mod_checking.cmo: ../lib/util.cmi univ.cmi typeops.cmi ../kernel/term.cmi \
+    subtyping.cmi reduction.cmi ../lib/pp.cmi ../kernel/names.cmi modops.cmi \
+    inductive.cmi indtypes.cmi ../lib/flags.cmi ../kernel/environ.cmi \
+    declarations.cmi 
+mod_checking.cmx: ../lib/util.cmx univ.cmx typeops.cmx ../kernel/term.cmx \
+    subtyping.cmx reduction.cmx ../lib/pp.cmi ../kernel/names.cmx modops.cmx \
+    inductive.cmx indtypes.cmx ../lib/flags.cmx ../kernel/environ.cmx \
+    declarations.cmx 
+modops.cmo: ../lib/util.cmi univ.cmi ../kernel/term.cmi ../lib/pp.cmi \
+    ../lib/option.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    declarations.cmi modops.cmi 
+modops.cmx: ../lib/util.cmx univ.cmx ../kernel/term.cmx ../lib/pp.cmi \
+    ../lib/option.cmx ../kernel/names.cmx ../kernel/environ.cmx \
+    declarations.cmx modops.cmi 
+modops.cmi: ../lib/util.cmi univ.cmi ../kernel/term.cmi ../kernel/names.cmi \
+    ../kernel/environ.cmi declarations.cmi 
+reduction.cmo: ../lib/util.cmi univ.cmi ../kernel/term.cmi \
+    ../kernel/names.cmi esubst.cmi ../kernel/environ.cmi closure.cmi \
+    reduction.cmi 
+reduction.cmx: ../lib/util.cmx univ.cmx ../kernel/term.cmx \
+    ../kernel/names.cmx esubst.cmx ../kernel/environ.cmx closure.cmx \
+    reduction.cmi 
+reduction.cmi: ../kernel/term.cmi ../kernel/environ.cmi 
+safe_typing.cmo: validate.cmo ../lib/util.cmi ../lib/pp.cmi ../lib/option.cmi \
+    ../kernel/names.cmi modops.cmi mod_checking.cmo ../kernel/environ.cmi \
+    declarations.cmi safe_typing.cmi 
+safe_typing.cmx: validate.cmx ../lib/util.cmx ../lib/pp.cmi ../lib/option.cmx \
+    ../kernel/names.cmx modops.cmx mod_checking.cmx ../kernel/environ.cmx \
+    declarations.cmx safe_typing.cmi 
+safe_typing.cmi: ../kernel/term.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    declarations.cmi 
+subtyping.cmo: ../lib/util.cmi univ.cmi typeops.cmi ../kernel/term.cmi \
+    reduction.cmi ../lib/pp.cmi ../kernel/names.cmi modops.cmi inductive.cmi \
+    ../kernel/environ.cmi declarations.cmi subtyping.cmi 
+subtyping.cmx: ../lib/util.cmx univ.cmx typeops.cmx ../kernel/term.cmx \
+    reduction.cmx ../lib/pp.cmi ../kernel/names.cmx modops.cmx inductive.cmx \
+    ../kernel/environ.cmx declarations.cmx subtyping.cmi 
+subtyping.cmi: univ.cmi ../kernel/term.cmi ../kernel/environ.cmi \
+    declarations.cmi 
+term.cmo: ../lib/util.cmi univ.cmi ../lib/pp.cmi ../lib/option.cmi \
+    ../kernel/names.cmi esubst.cmi 
+term.cmx: ../lib/util.cmx univ.cmx ../lib/pp.cmi ../lib/option.cmx \
+    ../kernel/names.cmx esubst.cmx 
+type_errors.cmo: ../kernel/term.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    type_errors.cmi 
+type_errors.cmx: ../kernel/term.cmx ../kernel/names.cmx ../kernel/environ.cmx \
+    type_errors.cmi 
+type_errors.cmi: ../kernel/term.cmi ../kernel/names.cmi ../kernel/environ.cmi 
+typeops.cmo: ../lib/util.cmi univ.cmi type_errors.cmi ../kernel/term.cmi \
+    reduction.cmi ../kernel/names.cmi inductive.cmi ../kernel/environ.cmi \
+    declarations.cmi typeops.cmi 
+typeops.cmx: ../lib/util.cmx univ.cmx type_errors.cmx ../kernel/term.cmx \
+    reduction.cmx ../kernel/names.cmx inductive.cmx ../kernel/environ.cmx \
+    declarations.cmx typeops.cmi 
+typeops.cmi: ../kernel/term.cmi ../kernel/names.cmi ../kernel/environ.cmi \
+    declarations.cmi 
+univ.cmo: ../lib/util.cmi ../lib/pp.cmi ../lib/option.cmi ../kernel/names.cmi \
+    univ.cmi 
+univ.cmx: ../lib/util.cmx ../lib/pp.cmi ../lib/option.cmx ../kernel/names.cmx \
+    univ.cmi 
+univ.cmi: ../lib/pp.cmi ../kernel/names.cmi 
diff --git a/checker/Makefile b/checker/Makefile
new file mode 100644
index 000000000..7567e78ff
--- /dev/null
+++ b/checker/Makefile
@@ -0,0 +1,86 @@
+OCAMLC=ocamlc
+OCAMLOPT=ocamlopt
+
+COQSRC=..
+
+MLDIRS=-I $(COQSRC)/config -I $(COQSRC)/lib -I $(COQSRC)/kernel -I +camlp4
+BYTEFLAGS=$(MLDIRS)
+OPTFLAGS=$(MLDIRS)
+
+CHECKERNAME=coqchk
+
+BINARIES=../bin/$(CHECKERNAME)$(EXE) ../bin/$(CHECKERNAME).opt$(EXE)
+
+MCHECKER:=\
+  $(COQSRC)/config/coq_config.cmo \
+  $(COQSRC)/lib/pp_control.cmo $(COQSRC)/lib/pp.cmo $(COQSRC)/lib/compat.cmo \
+  $(COQSRC)/lib/util.cmo $(COQSRC)/lib/option.cmo $(COQSRC)/lib/hashcons.cmo \
+  $(COQSRC)/lib/system.cmo $(COQSRC)/lib/flags.cmo \
+  $(COQSRC)/lib/predicate.cmo $(COQSRC)/lib/rtree.cmo \
+  $(COQSRC)/kernel/names.cmo $(COQSRC)/kernel/univ.cmo \
+  $(COQSRC)/kernel/esubst.cmo term.cmo \
+  declarations.cmo environ.cmo \
+  closure.cmo reduction.cmo \
+  type_errors.cmo \
+  modops.cmo \
+  inductive.cmo typeops.cmo \
+  indtypes.cmo subtyping.cmo mod_checking.cmo \
+validate.cmo \
+  safe_typing.cmo check.cmo \
+  check_stat.cmo checker.cmo
+
+all: $(BINARIES)
+
+byte : ../bin/$(CHECKERNAME)$(EXE)
+opt : ../bin/$(CHECKERNAME).opt$(EXE)
+
+check.cma: $(MCHECKER)
+	ocamlc $(BYTEFLAGS) -a -o $@ $(MCHECKER)
+
+check.cmxa: $(MCHECKER:.cmo=.cmx)
+	ocamlopt $(OPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx)
+
+../bin/$(CHECKERNAME)$(EXE): check.cma
+	ocamlc $(BYTEFLAGS) -o $@ unix.cma gramlib.cma check.cma main.ml
+
+../bin/$(CHECKERNAME).opt$(EXE): check.cmxa
+	ocamlopt $(OPTFLAGS) -o $@ unix.cmxa gramlib.cmxa check.cmxa main.ml
+
+stats:
+	@echo STRUCTURE
+	@wc names.ml term.ml declarations.ml environ.ml type_errors.ml
+	@echo
+	@echo REDUCTION
+	@-wc esubst.ml closure.ml reduction.ml
+	@echo
+	@echo TYPAGE
+	@wc univ.ml inductive.ml indtypes.ml typeops.ml safe_typing.ml
+	@echo
+	@echo MODULES
+	@wc modops.ml subtyping.ml
+	@echo
+	@echo INTERFACE
+	@wc check*.ml main.ml 
+	@echo
+	@echo TOTAL
+	@wc *.ml | tail -1
+
+.SUFFIXES:.ml .mli .cmi .cmo .cmx
+
+.ml.cmo:
+	$(OCAMLC) -c $(BYTEFLAGS) $<
+
+.ml.cmx:
+	$(OCAMLOPT) -c $(OPTFLAGS) $<
+
+.mli.cmi:
+	$(OCAMLC) -c $(BYTEFLAGS) $<
+
+
+depend::
+	ocamldep $(MLDIRS) *.ml* > .depend
+
+clean::
+	rm -f *.cm* *.o *.a *~ $(BINARIES)
+
+-include .depend
diff --git a/checker/check.ml b/checker/check.ml
new file mode 100644
index 000000000..6200a1582
--- /dev/null
+++ b/checker/check.ml
@@ -0,0 +1,357 @@
+(************************************************************************)
+(*  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: library.ml 9679 2007-02-24 15:22:07Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+
+let pr_id id = str (string_of_id id)
+let pr_dirpath dp = str (string_of_dirpath dp)
+let default_root_prefix = make_dirpath []
+let split_dirpath d =
+  let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l)
+let extend_dirpath p id = make_dirpath (id :: repr_dirpath p)
+
+type section_path = {
+  dirpath : string list ;
+  basename : string }
+let dir_of_path p =
+  make_dirpath
+    (id_of_string p.basename :: List.map id_of_string p.dirpath)
+let path_of_dirpath dir = 
+  match repr_dirpath dir with
+      [] -> failwith "path_of_dirpath"
+    | l::dir -> 
+        {dirpath=List.map string_of_id dir;basename=string_of_id l}
+let pr_dirlist dp =
+  prlist_with_sep (fun _ -> str".") str (List.rev dp)
+let pr_path sp =
+  match sp.dirpath with
+      [] -> str sp.basename
+    | sl -> pr_dirlist sl ++ str"." ++ str sp.basename
+
+type library_objects
+
+type compilation_unit_name = dir_path
+
+type library_disk = { 
+  md_name : compilation_unit_name;
+  md_compiled : Safe_typing.compiled_library;
+  md_objects : library_objects;
+  md_deps : (compilation_unit_name * Digest.t) list;
+  md_imports : compilation_unit_name list }
+
+(************************************************************************)
+(*s Modules on disk contain the following informations (after the magic 
+    number, and before the digest). *)
+
+(*s Modules loaded in memory contain the following informations. They are
+    kept in the global table [libraries_table]. *)
+
+type library_t = {
+  library_name : compilation_unit_name;
+  library_filename : System.physical_path;
+  library_compiled : Safe_typing.compiled_library;
+  library_deps : (compilation_unit_name * Digest.t) list;
+  library_digest : Digest.t }
+
+module LibraryOrdered = 
+  struct
+    type t = dir_path
+    let compare d1 d2 =
+      Pervasives.compare
+        (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
+  end
+
+module LibraryMap = Map.Make(LibraryOrdered)
+
+(* This is a map from names to loaded libraries *)
+let libraries_table = ref LibraryMap.empty
+
+(* various requests to the tables *)
+
+let find_library dir =
+  LibraryMap.find dir !libraries_table
+
+let try_find_library dir =
+  try find_library dir
+  with Not_found ->
+    error ("Unknown library " ^ (string_of_dirpath dir))
+
+let library_full_filename dir = (find_library dir).library_filename
+
+  (* If a library is loaded several time, then the first occurrence must
+     be performed first, thus the libraries_loaded_list ... *)
+
+let register_loaded_library m =
+  libraries_table := LibraryMap.add m.library_name m !libraries_table
+
+let check_one_lib admit (dir,m) =
+  let md = m.library_compiled in
+  let dig = m.library_digest in
+  if LibraryMap.mem dir admit then
+    (Flags.if_verbose msgnl
+      (str "Admitting library: " ++ pr_dirpath dir);
+      Safe_typing.unsafe_import md dig)
+  else
+    (Flags.if_verbose msgnl
+      (str "Checking library: " ++ pr_dirpath dir);
+      Safe_typing.import md dig);
+  Flags.if_verbose msg(fnl());
+  register_loaded_library m
+
+(*************************************************************************)
+(*s Load path. Mapping from physical to logical paths etc.*)
+
+type logical_path = dir_path
+
+let load_paths = ref ([],[] : System.physical_path list * logical_path list)
+
+let get_load_paths () = fst !load_paths
+
+(* Hints to partially detects if two paths refer to the same repertory *)
+let rec remove_path_dot p = 
+  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
+  let n = String.length curdir in
+  if String.length p > n && String.sub p 0 n = curdir then
+    remove_path_dot (String.sub p n (String.length p - n))
+  else
+    p
+
+let strip_path p =
+  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+  let n = String.length cwd in
+  if String.length p > n && String.sub p 0 n = cwd then
+    remove_path_dot (String.sub p n (String.length p - n))
+  else
+    remove_path_dot p
+
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  try 
+    Sys.chdir p;
+    let p' = Sys.getcwd () in
+    Sys.chdir current;
+    p'
+  with Sys_error _ ->
+    (* We give up to find a canonical name and just simplify it... *)
+    strip_path p
+
+let find_logical_path phys_dir = 
+  let phys_dir = canonical_path_name phys_dir in
+  match list_filter2 (fun p d -> p = phys_dir) !load_paths with
+  | _,[dir] -> dir
+  | _,[] -> default_root_prefix
+  | _,l -> anomaly ("Two logical paths are associated to "^phys_dir)
+
+let is_in_load_paths phys_dir =
+  let dir = canonical_path_name phys_dir in
+  let lp = get_load_paths () in
+  let check_p = fun p -> (String.compare dir p) == 0 in
+    List.exists check_p lp 
+
+let remove_load_path dir =
+  load_paths := list_filter2 (fun p d -> p <> dir) !load_paths
+
+let add_load_path (phys_path,coq_path) =
+  let phys_path = canonical_path_name phys_path in
+    match list_filter2 (fun p d -> p = phys_path) !load_paths with
+      | _,[dir] ->
+	  if coq_path <> dir 
+            (* If this is not the default -I . to coqtop *)
+            && not
+            (phys_path = canonical_path_name Filename.current_dir_name
+		&& coq_path = default_root_prefix)
+	  then
+	    begin
+              (* Assume the user is concerned by library naming *)
+	      if dir <> default_root_prefix then
+		Flags.if_warn msg_warning
+		  (str phys_path ++ strbrk " was previously bound to " ++
+		   pr_dirpath dir ++ strbrk "; it is remapped to " ++
+		   pr_dirpath coq_path);
+	      remove_load_path phys_path;
+	      load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths)
+	    end
+      | _,[] ->
+	  load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths)
+      | _ -> anomaly ("Two logical paths are associated to "^phys_path)
+
+let physical_paths (dp,lp) = dp
+
+let load_paths_of_dir_path dir =
+  fst (list_filter2 (fun p d -> d = dir) !load_paths)
+    
+let get_full_load_paths () = List.combine (fst !load_paths) (snd !load_paths)
+
+(************************************************************************)
+(*s Locate absolute or partially qualified library names in the path *)
+
+exception LibUnmappedDir
+exception LibNotFound
+type library_location = LibLoaded | LibInPath
+
+let locate_absolute_library dir =
+  (* Search in loadpath *)
+  let pref, base = split_dirpath dir in
+  let loadpath = load_paths_of_dir_path pref in
+  if loadpath = [] then raise LibUnmappedDir;
+  try
+    let name = string_of_id base^".vo" in
+    let _, file = System.where_in_path loadpath name in
+    (dir, file)
+  with Not_found ->
+  (* Last chance, removed from the file system but still in memory *)
+  try
+    (dir, library_full_filename dir)
+  with Not_found ->
+    raise LibNotFound
+
+let locate_qualified_library qid =
+  try
+    let loadpath =
+      (* Search library in loadpath *)
+      if qid.dirpath=[] then get_load_paths ()
+      else
+        (* we assume dir is an absolute dirpath *)
+        load_paths_of_dir_path (dir_of_path qid)
+    in
+    if loadpath = [] then raise LibUnmappedDir;
+    let name =  qid.basename^".vo" in
+    let path, file = System.where_in_path loadpath name in
+    let dir =
+      extend_dirpath (find_logical_path path) (id_of_string qid.basename) in
+    (* Look if loaded *)
+    try 
+      (LibLoaded, dir, library_full_filename dir)      
+    with Not_found ->
+      (LibInPath, dir, file)
+  with Not_found -> raise LibNotFound
+
+let explain_locate_library_error qid = function
+  | LibUnmappedDir ->
+      let prefix = qid.dirpath in
+      errorlabstrm "load_absolute_library_from"
+      (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ 
+      str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ())
+  | LibNotFound ->
+      errorlabstrm "load_absolute_library_from"
+      (str"Cannot find library " ++ pr_path qid ++ str" in loadpath")
+  | e -> raise e
+
+let try_locate_absolute_library dir =
+  try
+    locate_absolute_library dir
+  with e ->
+    explain_locate_library_error (path_of_dirpath dir) e
+
+let try_locate_qualified_library qid =
+  try
+    let (_,dir,f) = locate_qualified_library qid in
+    dir,f
+  with e -> 
+    explain_locate_library_error qid e
+
+(************************************************************************)
+(*s Low-level interning/externing of libraries to files *)
+
+(*s Loading from disk to cache (preparation phase) *)
+
+let vo_magic_number = 08190 (* trunk *)
+
+let (raw_extern_library, raw_intern_library) =
+  System.raw_extern_intern vo_magic_number ".vo"
+
+let with_magic_number_check f a =
+  try f a
+  with System.Bad_magic_number fname ->
+    errorlabstrm "with_magic_number_check"
+    (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++
+    spc () ++ str"It is corrupted" ++ spc () ++
+    str"or was compiled with another version of Coq.")
+
+(************************************************************************)
+(* Internalise libraries *)
+
+let mk_library md f digest = {
+  library_name = md.md_name;
+  library_filename = f;
+  library_compiled = md.md_compiled;
+  library_deps = md.md_deps;
+  library_digest = digest }
+
+let intern_from_file f =
+  pp (str"[intern "++str f++str" ..."); pp_flush();
+  let (md,digest) = 
+    try
+      let ch = with_magic_number_check raw_intern_library f in
+      let (md:library_disk) = System.marshal_in ch in
+      let digest = System.marshal_in ch in
+      close_in ch;
+      msgnl(str" done]");
+      md,digest
+    with e -> msgnl(str" failed!]"); raise e in
+  mk_library md f digest
+
+
+let name_clash_message dir mdir f =
+  str ("The file " ^ f ^ " contains library") ++ spc () ++
+  pr_dirpath mdir ++ spc () ++ str "and not library" ++ spc() ++
+  pr_dirpath dir
+
+let rec library_dep dir needed =
+  try let _ = find_library dir in needed
+  with Not_found ->
+  try let _ = LibraryMap.find dir needed in needed
+  with Not_found ->
+    let (_,f) = try_locate_absolute_library dir in
+    let m = intern_from_file f in
+    let deps = m.library_deps in
+    if dir <> m.library_name then
+      errorlabstrm "load_physical_library"
+        (name_clash_message dir m.library_name f);
+    LibraryMap.add dir f
+      (List.fold_right (fun (d,_) n -> library_dep d n) deps needed)
+
+let rec intern_library (dir, f) needed =
+  (* Look if in the current logical environment *)
+  try let _ = find_library dir in needed
+  with Not_found ->
+  (* Look if already listed and consequently its dependencies too *)
+  try let _ = List.assoc dir needed in needed
+  with Not_found ->
+  (* [dir] is an absolute name which matches [f] which must be in loadpath *)
+  let m = intern_from_file f in
+  if dir <> m.library_name then
+    errorlabstrm "load_physical_library"
+      (name_clash_message dir m.library_name f);
+  (dir,m)::List.fold_right intern_mandatory_library m.library_deps needed
+
+(* digest error with checked modules could be a warning *)
+and intern_mandatory_library (dir,_) needed =
+  intern_library (try_locate_absolute_library dir) needed
+
+let recheck_library ~admit ~check =
+  let al = List.map (fun q -> fst(try_locate_qualified_library q)) admit in
+  let admit = List.fold_right library_dep al LibraryMap.empty in
+  let modl = List.map try_locate_qualified_library check in
+  let needed = List.rev (List.fold_right intern_library modl []) in
+  msg(fnl());
+  Flags.if_verbose msgnl (hv 2 (str "Ordered list:" ++ fnl() ++
+    prlist
+    (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed));
+  List.iter (check_one_lib admit) needed;
+  msgnl(str"Modules were successfully checked"++fnl())
+
+open Printf
+
+let mem s =
+  let m = try_find_library s in
+  h 0 (str (sprintf "%dk" (size_kb m)))
diff --git a/checker/check_stat.ml b/checker/check_stat.ml
new file mode 100644
index 000000000..963665946
--- /dev/null
+++ b/checker/check_stat.ml
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+open Pp
+open Util
+open System
+open Flags
+open Names
+open Term
+open Declarations
+open Environ
+
+let memory_stat = ref false
+
+let print_memory_stat () = 
+  if !memory_stat then begin
+    Format.printf "total heap size = %d kbytes\n" (heap_size_kb ());
+    Format.print_newline();
+    flush_all()
+  end
+
+let output_context = ref false
+
+let pr_engt = function
+    Some ImpredicativeSet ->
+      str "Theory: Set is impredicative"
+  | None ->
+      str "Theory: Set is predicative"
+
+let cst_filter f csts =
+  Cmap.fold
+    (fun c ce acc -> if f c ce then c::acc else acc)
+    csts []
+
+let is_ax _ cb = cb.const_body = None 
+
+let pr_ax csts =
+  let axs = cst_filter is_ax csts in
+  if axs = [] then
+    str "Axioms: <none>"
+  else
+    hv 2 (str "Axioms:" ++ fnl() ++ prlist_with_sep fnl Indtypes.prcon axs)
+
+let print_context env =
+  if !output_context then begin
+    let
+      {env_globals=
+        {env_constants=csts; env_inductives=inds;
+         env_modules=mods; env_modtypes=mtys};
+       env_stratification=
+        {env_universes=univ; env_engagement=engt}} = env in
+    msgnl(hov 0
+      (str"CONTEXT SUMMARY" ++ fnl() ++
+      str"===============" ++ fnl() ++ fnl() ++
+      str "* " ++ hov 0 (pr_engt engt ++ fnl()) ++ fnl() ++
+      str "* " ++ hov 0 (pr_ax csts) ++
+      fnl()))
+  end
+
+let stats () =
+  print_context (Safe_typing.get_env());
+  print_memory_stat ()
+
+let _ = at_exit stats
diff --git a/checker/check_stat.mli b/checker/check_stat.mli
new file mode 100644
index 000000000..7037bd46c
--- /dev/null
+++ b/checker/check_stat.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+val memory_stat : bool ref
+val output_context : bool ref
+
+val stats : unit -> unit
diff --git a/checker/checker.ml b/checker/checker.ml
new file mode 100644
index 000000000..e96df366f
--- /dev/null
+++ b/checker/checker.ml
@@ -0,0 +1,374 @@
+(************************************************************************)
+(*  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: coqtop.ml 10153 2007-09-28 18:00:45Z glondu $ *)
+
+open Pp
+open Util
+open System
+open Flags
+open Names
+open Term
+open Check
+
+let coq_root = id_of_string "Coq"
+let parse_dir s =
+  let len = String.length s in
+  let rec decoupe_dirs dirs n =
+    if n>=len then dirs else
+    let pos =
+      try
+	String.index_from s n '.' 
+      with Not_found -> len
+    in
+    let dir = String.sub s n (pos-n) in
+      decoupe_dirs (dir::dirs) (pos+1)	  
+  in
+    decoupe_dirs [] 0
+let dirpath_of_string s = 
+  match parse_dir s with
+      [] -> invalid_arg "dirpath_of_string"
+    | dir -> make_dirpath (List.map id_of_string dir)
+let path_of_string s =
+  match parse_dir s with
+      [] -> invalid_arg "dirpath_of_string"
+    | l::dir -> {dirpath=dir; basename=l}
+
+let (/) = Filename.concat
+
+let get_version_date () =
+  try
+    let ch = open_in (Coq_config.coqlib^"/revision") in
+    let ver = input_line ch in
+    let rev = input_line ch in
+      (ver,rev)
+  with _ -> (Coq_config.version,Coq_config.date)
+
+let print_header () =
+  let (ver,rev) = (get_version_date ()) in
+    Printf.printf "Welcome to Coq %s (%s)\n" ver rev;
+    flush stdout
+
+(* Adding files to Coq loadpath *)
+
+let add_path ~unix_path:dir ~coq_root:coq_dirpath =
+  if exists_dir dir then
+    begin
+      Check.add_load_path (dir,coq_dirpath)
+    end
+  else
+    msg_warning (str ("Cannot open " ^ dir))
+
+let convert_string d =
+  try id_of_string d
+  with _ -> 
+    if_verbose warning 
+      ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
+    flush_all ();
+    failwith "caught"
+
+let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
+  let dirs = all_subdirs dir in
+  let prefix = repr_dirpath coq_dirpath in
+  if dirs <> [] then
+    let convert_dirs (lp,cp) =
+      (lp,Names.make_dirpath
+            ((List.map convert_string (List.rev cp))@prefix)) in
+    let dirs = map_succeed convert_dirs dirs in
+    begin
+      List.iter Check.add_load_path dirs
+    end
+  else
+    msg_warning (str ("Cannot open " ^ dir))
+
+(* By the option -include -I or -R of the command line *)
+let includes = ref []
+let push_include (s, alias) = includes := (s,alias,false) :: !includes
+let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
+
+let check_coq_overwriting p = 
+  if string_of_id (list_last (repr_dirpath p)) = "Coq" then
+    error "The \"Coq\" logical root directory is reserved for the Coq library"
+
+let set_default_include d =
+  push_include (d, Check.default_root_prefix)
+let set_default_rec_include d =
+  let p = Check.default_root_prefix in
+  check_coq_overwriting p; 
+  push_rec_include (d, p)
+
+let safe_getenv_def var def =
+  try 
+    Sys.getenv var
+  with Not_found ->
+    warning ("Environment variable "^var^" not found: using '"^def^"' .");
+    flush_all();
+    def
+
+(* Initializes the LoadPath according to COQLIB and Coq_config *)
+let init_load_path () =
+  let coqlib =
+    (* variable COQLIB overrides the default library *)
+    safe_getenv_def "COQLIB"
+      (if Coq_config.local || !Flags.boot then Coq_config.coqtop
+	else Coq_config.coqlib) in
+  let user_contrib = coqlib/"user-contrib" in
+  let contrib = coqlib/"contrib" in
+  (* first user-contrib *)
+  if Sys.file_exists user_contrib then 
+    add_rec_path user_contrib Check.default_root_prefix;
+  (* then contrib *)
+  add_rec_path contrib (Names.make_dirpath [coq_root]);
+  (* then standard library *)
+(*  List.iter 
+    (fun (s,alias) ->
+      add_rec_path (coqlib/s) ([alias; coq_root])) 
+    theories_dirs_map;*)
+  add_rec_path (coqlib/"theories") (Names.make_dirpath[coq_root]);
+  (* then current directory *)
+  add_path "." Check.default_root_prefix;
+  (* additional loadpath, given with -I -include -R options *)
+  List.iter 
+    (fun (s,alias,reci) ->
+      if reci then add_rec_path s alias else add_path s alias)
+    (List.rev !includes);
+  includes := []
+
+
+let set_debug () = Flags.debug := true
+
+let engagement = ref None
+let set_engagement c = engagement := Some c
+let engage () =
+  match !engagement with Some c -> Safe_typing.set_engagement c | None -> ()
+
+
+let admit_list = ref ([] : section_path list)
+let add_admit s =
+  admit_list := path_of_string s :: !admit_list
+
+let compile_list = ref ([] : section_path list)
+let add_compile s =
+  compile_list := path_of_string s :: !compile_list
+
+(*s Parsing of the command line.
+    We no longer use [Arg.parse], in order to use share [Usage.print_usage]
+    between coqtop and coqc. *)
+
+let compile_files () =
+  Check.recheck_library
+    ~admit:(List.rev !admit_list)
+    ~check:(List.rev !compile_list) 
+
+let version () =
+  Printf.printf "The Coq Proof Checker, version %s (%s)\n"
+    Coq_config.version Coq_config.date;
+  Printf.printf "compiled on %s\n" Coq_config.compile_date;
+  exit 0
+
+(* print the usage of coqtop (or coqc) on channel co *)
+
+let print_usage_channel co command =
+  output_string co command;
+  output_string co "Coq options are:\n";
+  output_string co
+"  -I dir                 add directory dir in the include path
+  -include dir           (idem)
+  -R dir coqdir          recursively map physical dir to logical coqdir 
+
+  -admit module          load module and dependencies without checking
+
+  -where                 print Coq's standard library location and exit
+  -v                     print Coq version and exit
+
+  -h, --help             print this list of options
+"
+
+(* print the usage on standard error *)
+
+let print_usage = print_usage_channel stderr
+
+let print_usage_coqtop () =
+  print_usage "Usage: checker <options>\n\n"
+
+let usage () =
+  print_usage_coqtop ();
+  flush stderr;
+  exit 1
+
+let warning s = msg_warning (str s)
+
+open Type_errors
+
+let anomaly_string () = str "Anomaly: "
+let report () = (str "." ++ spc () ++ str "Please report.")
+
+let print_loc loc =
+  if loc = dummy_loc then 
+    (str"<unknown>")
+  else 
+    let loc = unloc loc in
+    (int (fst loc) ++ str"-" ++ int (snd loc))
+let guill s = "\""^s^"\""
+
+let where s =
+  if !Flags.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
+
+let rec explain_exn = function
+  | Stream.Failure -> 
+      hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.")
+  | Stream.Error txt -> 
+      hov 0 (str "Syntax error: " ++ str txt)
+  | Token.Error txt -> 
+      hov 0 (str "Syntax error: " ++ str txt)
+  | Sys_error msg -> 
+      hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() )
+  | UserError(s,pps) -> 
+      hov 1 (str "User error: " ++ where s ++ pps)
+  | Out_of_memory -> 
+      hov 0 (str "Out of memory")
+  | Stack_overflow -> 
+      hov 0 (str "Stack overflow")
+  | Anomaly (s,pps) -> 
+      hov 1 (anomaly_string () ++ where s ++ pps ++ report ())
+  | Match_failure(filename,pos1,pos2) ->
+      hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ 
+      if Sys.ocaml_version = "3.06" then
+		   (str " from character " ++ int pos1 ++ 
+                    str " to " ++ int pos2)
+		 else
+		   (str " at line " ++ int pos1 ++
+		    str " character " ++ int pos2)
+	           ++ report ())
+  | Not_found -> 
+      hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ())
+  | Failure s -> 
+      hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report ())
+  | Invalid_argument s -> 
+      hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report ())
+  | Sys.Break -> 
+      hov 0 (fnl () ++ str "User interrupt.")
+  | Univ.UniverseInconsistency (o,u,v) ->
+      let msg = 
+	if !Flags.debug (*!Constrextern.print_universes*) then
+	  spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++
+          str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=")
+	  ++ spc() ++ (*Univ.pr_uni v ++*) str")"
+	else
+	  mt() in
+      hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".")
+  | TypeError(ctx,te) -> 
+(*      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx *)
+      (*      te)*)
+      hov 0 (str "Type error")
+
+  | Indtypes.InductiveError e -> 
+      hov 0 (str "Error related to inductive types")
+(*      let ctx = Check.get_env() in
+      hov 0
+        (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*)
+  | Stdpp.Exc_located (loc,exc) ->
+      hov 0 ((if loc = dummy_loc then (mt ())
+               else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
+               ++ explain_exn exc)
+  | Assert_failure (s,b,e) ->
+      hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
+	       (if s <> "" then 
+		 if Sys.ocaml_version = "3.06" then
+		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
+		    int b ++ str "-" ++ int e ++ str ")")
+		 else
+		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
+		    str ", characters " ++ int e ++ str "-" ++
+		    int (e+6) ++ str ")")
+	       else
+		 (mt ())) ++
+	       report ())
+  | reraise ->
+      hov 0 (anomaly_string () ++ str "Uncaught exception " ++ 
+	       str (Printexc.to_string reraise)++report())
+
+let parse_args() =
+  let rec parse = function
+    | [] -> ()
+   | "-impredicative-set" :: rem -> 
+       set_engagement Declarations.ImpredicativeSet; parse rem
+
+    | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem
+    | ("-I"|"-include") :: []       -> usage ()
+
+    | "-R" :: d :: p :: rem ->
+        push_rec_include (d, dirpath_of_string p);parse rem
+    | "-R" :: ([] | [_]) -> usage ()
+
+    | "-debug" :: rem -> set_debug (); parse rem
+
+    | "-where" :: _ ->
+        print_endline (getenv_else "COQLIB" Coq_config.coqlib); exit 0
+
+    | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
+
+    | ("-v"|"--version") :: _ -> version ()
+
+    | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem
+
+    | ("-o" | "-output-context") :: rem ->
+        Check_stat.output_context := true; parse rem
+
+    | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem
+
+    | "-admit" :: s :: rem -> add_admit s; parse rem
+    | "-admit" :: [] -> usage ()
+
+    | "-silent" :: rem ->
+        Flags.make_silent true; parse rem
+
+    | s :: _ when s<>"" && s.[0]='-' ->
+        msgnl (str "Unknown option " ++ str s); exit 1
+    | s :: rem ->  add_compile s; parse rem
+  in
+  try
+    parse (List.tl (Array.to_list Sys.argv))
+  with 
+    | UserError(_,s) as e -> begin
+	try
+	  Stream.empty s; exit 1
+	with Stream.Failure ->
+	  msgnl (explain_exn e); exit 1
+      end
+    | e -> begin msgnl (explain_exn e); exit 1 end
+
+
+(* To prevent from doing the initialization twice *)
+let initialized = ref false
+
+let init() =
+  if not !initialized then begin
+    initialized := true;
+    Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+    try
+      parse_args();
+      if_verbose print_header ();
+      init_load_path ();
+      engage ();
+    with e ->
+      flush_all();
+      message "Error during initialization :";
+      msgnl (explain_exn e);
+      exit 1
+  end
+
+let run () =
+  (try 
+    compile_files ()
+  with e ->
+    Pp.ppnl(explain_exn e));
+    flush_all(); 
+    if not !Flags.debug then exit 0
+
+let start () = init(); run()
diff --git a/checker/closure.ml b/checker/closure.ml
new file mode 100644
index 000000000..ccbfbc4c0
--- /dev/null
+++ b/checker/closure.ml
@@ -0,0 +1,1047 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: closure.ml 9983 2007-07-12 17:15:22Z barras $ *)
+
+open Util
+open Pp
+open Term
+open Names
+open Esubst
+open Environ
+
+let stats = ref false
+let share = ref true
+
+(* Profiling *)
+let beta = ref 0
+let delta = ref 0
+let zeta = ref 0
+let evar = ref 0
+let iota = ref 0
+let prune = ref 0
+
+let reset () =
+  beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0
+
+let stop() =
+  msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+	 str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++
+         str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]")
+
+let incr_cnt red cnt =
+  if red then begin
+    if !stats then incr cnt;
+    true
+  end else 
+    false
+
+let with_stats c =
+  if !stats then begin
+    reset();
+    let r = Lazy.force c in
+    stop();
+    r
+  end else
+    Lazy.force c
+
+type transparent_state = Idpred.t * Cpred.t
+let all_opaque = (Idpred.empty, Cpred.empty)
+let all_transparent = (Idpred.full, Cpred.full)
+
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+  val no_red : reds
+  val red_add : reds -> red_kind -> reds
+  val red_sub : reds -> red_kind -> reds
+  val red_add_transparent : reds -> transparent_state -> reds
+  val mkflags : red_kind list -> reds
+  val red_set : reds -> red_kind -> bool
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags = (struct
+
+  (* [r_const=(true,cl)] means all constants but those in [cl] *)
+  (* [r_const=(false,cl)] means only those in [cl] *)
+  (* [r_delta=true] just mean [r_const=(true,[])] *)
+
+  type reds = {
+    r_beta : bool;
+    r_delta : bool;
+    r_const : transparent_state;
+    r_zeta : bool;
+    r_evar : bool;
+    r_iota : bool }
+
+  type red_kind = BETA | DELTA | IOTA | ZETA
+	      | CONST of constant | VAR of identifier
+  let fBETA = BETA
+  let fDELTA = DELTA
+  let fIOTA = IOTA
+  let fZETA = ZETA
+  let fCONST kn  = CONST kn
+  let fVAR id  = VAR id
+  let no_red = {
+    r_beta = false;
+    r_delta = false;
+    r_const = all_opaque;
+    r_zeta = false;
+    r_evar = false;
+    r_iota = false }
+
+  let red_add red = function
+    | BETA -> { red with r_beta = true }
+    | DELTA -> { red with r_delta = true; r_const = all_transparent }
+    | CONST kn ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = l1, Cpred.add kn l2 }
+    | IOTA -> { red with r_iota = true }
+    | ZETA -> { red with r_zeta = true }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.add id l1, l2 }
+
+  let red_sub red = function
+    | BETA -> { red with r_beta = false }
+    | DELTA -> { red with r_delta = false }
+    | CONST kn ->
+ 	let (l1,l2) = red.r_const in
+	{ red with r_const = l1, Cpred.remove kn l2 }
+    | IOTA -> { red with r_iota = false }
+    | ZETA -> { red with r_zeta = false }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.remove id l1, l2 }
+
+  let red_add_transparent red tr =
+    { red with r_const = tr } 
+
+  let mkflags = List.fold_left red_add no_red
+
+  let red_set red = function
+    | BETA -> incr_cnt red.r_beta beta
+    | CONST kn -> 
+	let (_,l) = red.r_const in
+	let c = 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
+	let c = Idpred.mem id l in
+	incr_cnt c delta
+    | ZETA -> incr_cnt red.r_zeta zeta
+    | IOTA -> incr_cnt red.r_iota iota
+    | DELTA -> (* Used for Rel/Var defined in context *)
+	incr_cnt red.r_delta delta
+
+  let red_get_const red =
+    let p1,p2 = red.r_const in
+    let (b1,l1) = Idpred.elements p1 in
+    let (b2,l2) = Cpred.elements p2 in
+    if b1=b2 then
+      let l1' = List.map (fun x -> EvalVarRef x) l1 in
+      let l2' = List.map (fun x -> EvalConstRef x) l2 in
+      (b1, l1' @ l2')
+    else error "unrepresentable pair of predicate"
+
+end : RedFlagsSig)
+
+open RedFlags
+
+let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA]
+let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
+let betaiota = mkflags [fBETA;fIOTA]
+let beta = mkflags [fBETA]
+let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
+let unfold_red kn = 
+  let flag = match kn with
+    | EvalVarRef id -> fVAR id
+    | EvalConstRef kn -> fCONST kn
+  in (* Remove fZETA for finer behaviour ? *)
+  mkflags [fBETA;flag;fIOTA;fZETA]
+
+(************************* Obsolète
+(* [r_const=(true,cl)] means all constants but those in [cl] *)
+(* [r_const=(false,cl)] means only those in [cl] *)
+type reds = {
+  r_beta : bool;
+  r_const : bool * constant_path list * identifier list;
+  r_zeta : bool;
+  r_evar : bool;
+  r_iota : bool }
+
+let betadeltaiota_red = {
+  r_beta = true;
+  r_const = true,[],[];
+  r_zeta = true;
+  r_evar = true;
+  r_iota = true } 
+
+let betaiota_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = true }
+		     
+let beta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let no_red = {
+  r_beta = false;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let betaiotazeta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = true;
+  r_evar = false;
+  r_iota = true }
+
+let unfold_red kn =
+  let c = match kn with
+    | EvalVarRef id -> false,[],[id]
+    | EvalConstRef kn -> false,[kn],[]
+  in {
+  r_beta = true;
+  r_const = c;
+  r_zeta = true;   (* false for finer behaviour ? *)
+  r_evar = false;
+  r_iota = true }
+
+(* Sets of reduction kinds.
+   Main rule: delta implies all consts (both global (= by
+   kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
+   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+   a LetIn expression is Letin reduction *)
+
+type red_kind =
+    BETA | DELTA | ZETA | IOTA
+  | CONST of constant_path list | CONSTBUT of constant_path list
+  | VAR of identifier | VARBUT of identifier
+
+let rec red_add red = function
+  | BETA -> { red with r_beta = true }
+  | DELTA ->
+      (match red.r_const with
+	| _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags"
+	| _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true })
+  | CONST cl ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 })
+  | CONSTBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, list_union cl l1, l2;
+		r_zeta = true; r_evar = true })
+  | IOTA -> { red with r_iota = true }
+  | ZETA -> { red with r_zeta = true }
+  | VAR id ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 })
+  | VARBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, l1, list_union [cl] l2;
+		r_zeta = true; r_evar = true })
+
+let red_delta_set red =
+  let b,_,_ = red.r_const in b
+
+let red_local_const = red_delta_set
+
+(* to know if a redex is allowed, only a subset of red_kind is used ... *)
+let red_set red = function
+  | BETA -> incr_cnt red.r_beta beta
+  | CONST [kn] -> 
+      let (b,l,_) = red.r_const in
+      let c = List.mem kn l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | VAR id -> (* En attendant d'avoir des kn pour les Var *)
+     let (b,_,l) = red.r_const in
+      let c = List.mem id l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | ZETA -> incr_cnt red.r_zeta zeta
+  | EVAR -> incr_cnt red.r_zeta evar
+  | IOTA -> incr_cnt red.r_iota iota
+  | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*)
+  (* Not for internal use *)
+  | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented"
+
+(* Gives the constant list *)
+let red_get_const red =
+  let b,l1,l2 = red.r_const in
+  let l1' = List.map (fun x -> EvalConstRef x) l1 in
+  let l2' = List.map (fun x -> EvalVarRef x) l2 in
+  b, l1' @ l2'
+fin obsolète **************)
+(* specification of the reduction function *)
+
+
+(* Flags of reduction and cache of constants: 'a is a type that may be
+ * mapped to constr. 'a infos implements a cache for constants and
+ * abstractions, storing a representation (of type 'a) of the body of
+ * this constant or abstraction.
+ *  * i_tab is the cache table of the results
+ *  * i_repr is the function to get the representation from the current
+ *         state of the cache and the body of the constant. The result
+ *         is stored in the table.
+ *  * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables
+ *    and only those with index 1 and 3 have bodies which are c and d resp.
+ *  * i_vars is the list of _defined_ named variables.
+ *
+ * ref_value_cache searchs in the tab, otherwise uses i_repr to
+ * compute the result and store it in the table. If the constant can't
+ * be unfolded, returns None, but does not store this failure.  * This
+ * doesn't take the RESET into account. You mustn't keep such a table
+ * after a Reset.  * This type is not exported. Only its two
+ * instantiations (cbv or lazy) are.
+ *)
+
+type table_key =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of int
+
+type 'a infos = {
+  i_flags : reds;
+  i_repr : 'a infos -> constr -> 'a;
+  i_env : env;
+  i_rels : int * (int * constr) list;
+  i_vars : (identifier * constr) list;
+  i_tab : (table_key, 'a) Hashtbl.t }
+
+let info_flags info = info.i_flags
+
+let ref_value_cache info ref =
+  try  
+    Some (Hashtbl.find info.i_tab ref)
+  with Not_found ->
+  try
+    let body =
+      match ref with
+	| 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
+    in
+    let v = info.i_repr info body in
+    Hashtbl.add info.i_tab ref v;
+    Some v
+  with
+    | Not_found (* List.assoc *)
+    | NotEvaluableConst _ (* Const *)
+      -> None
+
+let defined_vars flags env =
+(*  if red_local_const (snd flags) then*)
+    fold_named_context 
+      (fun (id,b,_) e ->
+	 match b with
+	   | None -> e
+	   | Some body -> (id, body)::e)
+       (named_context env) ~init:[]
+(*  else []*)
+
+let defined_rels flags env =
+(*  if red_local_const (snd flags) then*)
+  fold_rel_context 
+      (fun (id,b,t) (i,subs) ->
+	 match b with
+	   | None -> (i+1, subs)
+	   | Some body -> (i+1, (i,body) :: subs))
+      (rel_context env) ~init:(0,[])
+(*  else (0,[])*)
+
+let mind_equiv_infos info = mind_equiv info.i_env
+
+let create mk_cl flgs env =
+  { i_flags = flgs;
+    i_repr = mk_cl;
+    i_env = env;
+    i_rels = defined_rels flgs env;
+    i_vars = defined_vars flgs env;
+    i_tab = Hashtbl.create 17 }
+
+
+(**********************************************************************)
+(* Lazy reduction: the one used in kernel operations                  *)
+
+(* type of shared terms. fconstr and frterm are mutually recursive.
+ * Clone of the constr structure, but completely mutable, and
+ * annotated with reduction state (reducible or not).
+ *  - FLIFT is a delayed shift; allows sharing between 2 lifted copies
+ *    of a given term.
+ *  - FCLOS is a delayed substitution applied to a constr
+ *  - FLOCKED is used to erase the content of a reference that must
+ *    be updated. This is to allow the garbage collector to work
+ *    before the term is computed.
+ *)
+
+(* Norm means the term is fully normalized and cannot create a redex
+     when substituted
+   Cstr means the term is in head normal form and that it can
+     create a redex when substituted (i.e. constructor, fix, lambda)
+   Whnf means we reached the head normal form and that it cannot
+     create a redex when substituted
+   Red is used for terms that might be reduced
+*)
+type red_state = Norm | Cstr | Whnf | Red
+
+let neutr = function
+  | (Whnf|Norm) -> Whnf
+  | (Red|Cstr) -> Red
+
+type fconstr = { 
+  mutable norm: red_state; 
+  mutable term: fterm }
+
+and fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * cast_kind * fconstr
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+let fterm_of v = v.term
+let set_norm v = v.norm <- Norm
+let is_val v = v.norm = Norm
+
+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) =
+  if !share then
+    (v1.norm <- no;
+     v1.term <- t;
+     v1)
+  else {norm=no;term=t}
+
+(**********************************************************************)
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+
+type stack_member =
+  | Zapp of fconstr array
+  | Zcase of case_info * fconstr * fconstr array
+  | Zfix of fconstr * stack
+  | Zshift of int
+  | Zupdate of fconstr
+
+and stack = stack_member list
+
+let empty_stack = []
+let append_stack v s =
+  if Array.length v = 0 then s else
+  match s with
+  | Zapp l :: s -> Zapp (Array.append v l) :: s
+  | _ -> Zapp v :: s
+
+(* Collapse the shifts in the stack *)
+let zshift n s =
+  match (n,s) with
+      (0,_) -> s
+    | (_,Zshift(k)::s) -> Zshift(n+k)::s
+    | _ -> Zshift(n)::s
+
+let rec stack_args_size = function
+  | Zapp v :: s -> Array.length v + stack_args_size s
+  | Zshift(_)::s -> stack_args_size s
+  | Zupdate(_)::s -> stack_args_size s
+  | _ -> 0
+
+(* When used as an argument stack (only Zapp can appear) *)
+let rec decomp_stack = function
+  | Zapp v :: s ->
+      (match Array.length v with
+          0 -> decomp_stack s
+        | 1 -> Some (v.(0), s)
+        | _ ->
+            Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s)))
+  | _ -> None
+let rec decomp_stackn = function
+  | Zapp v :: s -> if Array.length v = 0 then decomp_stackn s else (v, s)
+  | _ -> assert false
+let array_of_stack s =
+  let rec stackrec = function
+  | [] -> []
+  | Zapp args :: s -> args :: (stackrec s)
+  | _ -> assert false
+  in Array.concat (stackrec s)
+let rec stack_assign s p c = match s with
+  | Zapp args :: s ->
+      let q = Array.length args in 
+      if p >= q then
+	Zapp args :: stack_assign s (p-q) c
+      else
+        (let nargs = Array.copy args in
+         nargs.(p) <- c;
+         Zapp nargs :: s)
+  | _ -> s
+let rec stack_tail p s = 
+  if p = 0 then s else
+    match s with
+      | Zapp args :: s ->
+	  let q = Array.length args in
+	  if p >= q then stack_tail (p-q) s
+	  else Zapp (Array.sub args p (q-p)) :: s
+      | _ -> failwith "stack_tail"
+let rec stack_nth s p = match s with
+  | Zapp args :: s ->
+      let q = Array.length args in
+      if p >= q then stack_nth s (p-q)
+      else args.(p)
+  | _ -> raise Not_found
+
+(* Lifting. Preserves sharing (useful only for cell with norm=Red).
+   lft_fconstr always create a new cell, while lift_fconstr avoids it
+   when the lift is 0. *)
+let rec lft_fconstr n ft =
+  match ft.term with
+    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft
+    | FRel i -> {norm=Norm;term=FRel(i+n)}
+    | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))}
+    | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))}
+    | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))}
+    | FLIFT(k,m) -> lft_fconstr (n+k) m
+    | FLOCKED -> assert false
+    | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
+let lift_fconstr k f =
+  if k=0 then f else lft_fconstr k f
+let lift_fconstr_vect k v =
+  if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
+let lift_fconstr_list k l =
+  if k=0 then l else List.map (fun f -> lft_fconstr k f) l
+
+let clos_rel e i =
+  match expand_rel i e with
+    | Inl(n,mt) -> lift_fconstr n mt
+    | Inr(k,None) -> {norm=Norm; term= FRel k}
+    | Inr(k,Some p) ->
+        lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)}
+
+(* since the head may be reducible, we might introduce lifts of 0 *)
+let compact_stack head stk =
+  let rec strip_rec depth = function
+    | Zshift(k)::s -> strip_rec (depth+k) s
+    | Zupdate(m)::s ->
+        (* Be sure to create a new cell otherwise sharing would be
+           lost by the update operation *)
+        let h' = lft_fconstr depth head in
+        let _ = update m (h'.norm,h'.term) in
+        strip_rec depth s
+    | stk -> zshift depth stk in
+  strip_rec 0 stk
+
+(* Put an update mark in the stack, only if needed *)
+let zupdate m s =
+  if !share & m.norm = Red
+  then
+    let s' = compact_stack m s in
+    let _ = m.term <- FLOCKED in
+    Zupdate(m)::s'
+  else s
+
+(* Closure optimization: *)
+let rec compact_constr (lg, subs as s) c k =
+  match c with
+      Rel i ->
+        if i < k then c,s else
+          (try Rel (k + lg - list_index (i-k+1) subs), (lg,subs)
+          with Not_found -> Rel (k+lg), (lg+1, (i-k+1)::subs))
+    | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s
+    | Evar(ev,v) ->
+        let (v',s) = compact_vect s v k in
+        if v==v' then c,s else Evar(ev,v'),s
+    | 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 Cast(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
+        if f==f' && v==v' then c,s else App(f',v'), s
+    | Lambda(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else Lambda(n,a',b'), s
+    | Prod(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else Prod(n,a',b'), s
+    | LetIn(n,a,ty,b) ->
+        let (a',s) = compact_constr s a k in
+        let (ty',s) = compact_constr s ty k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && ty==ty' && b==b' then c,s else LetIn(n,a',ty',b'), s
+    | Fix(fi,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else Fix(fi,(na,ty',bd')), s
+    | CoFix(i,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else CoFix(i,(na,ty',bd')), s
+    | Case(ci,p,a,br) ->
+        let (p',s) = compact_constr s p k in
+        let (a',s) = compact_constr s a k in
+        let (br',s) = compact_vect s br k in
+        if p==p' && a==a' && br==br' then c,s else Case(ci,p',a',br'),s
+and compact_vect s v k = compact_v [] s v k (Array.length v - 1)
+and compact_v acc s v k i =
+  if i < 0 then
+    let v' = Array.of_list acc in
+    if array_for_all2 (==) v v' then v,s else v',s
+  else
+    let (a',s') = compact_constr s v.(i) k in
+    compact_v (a'::acc) s' v k (i-1)
+
+(* Computes the minimal environment of a closure.
+   Idea: if the subs is not identity, the term will have to be
+   reallocated entirely (to propagate the substitution). So,
+   computing the set of free variables does not change the
+   complexity. *)
+let optimise_closure env c =
+  if is_subs_id env then (env,c) else
+    let (c',(_,s)) = compact_constr (0,[]) c 1 in
+    let env' =
+      Array.map (fun i -> clos_rel env i) (Array.of_list s) in
+    (subs_cons (env', ESID 0),c')
+
+let mk_lambda env t =
+  let (env,t) = optimise_closure env t in
+  let (rvars,t') = decompose_lam t in
+  FLambda(List.length rvars, List.rev rvars, t', env)
+
+let destFLambda clos_fun t =
+  match t.term with
+      FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b)
+    | FLambda(n,(na,ty)::tys,b,e) ->
+        (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)})
+    | _ -> assert false
+
+(* Optimization: do not enclose variables in a closure.
+   Makes variable access much faster *)
+let mk_clos e t =
+  match t with
+    | Rel i -> clos_rel e i
+    | Var x -> { norm = Red; term = FFlex (VarKey x) }
+    | Const c -> { norm = Red; term = FFlex (ConstKey c) }
+    | Meta _ | Sort _ ->  { norm = Norm; term = FAtom t }
+    | Ind kn -> { norm = Norm; term = FInd kn }
+    | Construct kn -> { norm = Cstr; term = FConstruct kn }
+    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) ->
+        {norm = Red; term = FCLOS(t,e)}
+
+let mk_clos_vect env v = Array.map (mk_clos env) v
+
+(* Translate the head constructor of t from constr to fconstr. This
+   function is parameterized by the function to apply on the direct
+   subterms.
+   Could be used insted of mk_clos. *)
+let mk_clos_deep clos_fun env t =
+  match t with
+    | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) ->
+        mk_clos env t
+    | Cast (a,k,b) ->
+        { norm = Red;
+          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) }
+    | Case (ci,p,c,v) ->
+        { norm = Red;
+	  term = FCases (ci, clos_fun env p, clos_fun env c,
+			 Array.map (clos_fun env) v) }
+    | Fix fx ->
+        { norm = Cstr; term = FFix (fx, env) }
+    | CoFix cfx ->
+        { norm = Cstr; term = FCoFix(cfx,env) }
+    | Lambda _ ->
+        { norm = Cstr; term = mk_lambda env t }
+    | Prod (n,t,c)   ->
+        { norm = Whnf;
+	  term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) }
+    | LetIn (n,b,t,c) ->
+        { norm = Red;
+	  term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) }
+    | Evar(ev,args) ->
+	{ norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) }
+
+(* A better mk_clos? *)
+let mk_clos2 = mk_clos_deep mk_clos
+
+(* The inverse of mk_clos_deep: move back to constr *)
+let rec to_constr constr_fun lfts v =
+  match v.term with
+    | FRel i -> Rel (reloc_rel i lfts)
+    | FFlex (RelKey p) -> Rel (reloc_rel p lfts)
+    | FFlex (VarKey x) -> Var x
+    | FAtom c -> exliftn lfts c
+    | FCast (a,k,b) ->
+        Cast (constr_fun lfts a, k, constr_fun lfts b)
+    | FFlex (ConstKey op) -> Const op
+    | FInd op -> Ind op
+    | FConstruct op -> Construct op
+    | FCases (ci,p,c,ve) ->
+	Case (ci, constr_fun lfts p,
+              constr_fun lfts c,
+	      Array.map (constr_fun lfts) ve)
+    | FFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn n lfts in
+	Fix (op, (lna, Array.map (constr_fun lfts) ftys,
+	               Array.map (constr_fun lfts') fbds))
+    | FCoFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn (Array.length bds) lfts in
+	CoFix (op, (lna, Array.map (constr_fun lfts) ftys,
+	                 Array.map (constr_fun lfts') fbds))
+    | FApp (f,ve) ->
+	App (constr_fun lfts f,
+	       Array.map (constr_fun lfts) ve)
+    | FLambda _ ->
+        let (na,ty,bd) = destFLambda mk_clos2 v in
+	Lambda (na, constr_fun lfts ty,
+	            constr_fun (el_lift lfts) bd)
+    | FProd (n,t,c)   ->
+	Prod (n, constr_fun lfts t,
+	         constr_fun (el_lift lfts) c)
+    | FLetIn (n,b,t,f,e) ->
+        let fc = mk_clos2 (subs_lift e) f in
+	LetIn (n, constr_fun lfts b,
+	          constr_fun lfts t,
+	          constr_fun (el_lift lfts) fc)
+    | FEvar (ev,args) -> Evar(ev,Array.map (constr_fun lfts) args)
+    | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
+    | FCLOS (t,env) ->
+        let fr = mk_clos2 env t in
+        let unfv = update v (fr.norm,fr.term) in
+        to_constr constr_fun lfts unfv
+    | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*)
+
+(* This function defines the correspondance between constr and
+   fconstr. When we find a closure whose substitution is the identity,
+   then we directly return the constr to avoid possibly huge
+   reallocation. *)
+let term_of_fconstr =
+  let rec term_of_fconstr_lift lfts v =
+    match v.term with
+      | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t
+      | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts ->
+          compose_lam (List.rev tys) f
+      | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> Fix fx
+      | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> CoFix cfx
+      | _ -> to_constr term_of_fconstr_lift lfts v in
+  term_of_fconstr_lift ELID
+
+
+
+(* fstrong applies unfreeze_fun recursively on the (freeze) term and
+ * yields a term.  Assumes that the unfreeze_fun never returns a
+ * FCLOS term. 
+let rec fstrong unfreeze_fun lfts v =
+  to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
+*)
+
+let rec zip m stk =
+  match stk with
+    | [] -> m
+    | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
+    | Zcase(ci,p,br)::s ->
+        let t = FCases(ci, p, m, br) in
+        zip {norm=neutr m.norm; term=t} s
+    | Zfix(fx,par)::s ->
+        zip fx (par @ append_stack [|m|] s)
+    | Zshift(n)::s ->
+        zip (lift_fconstr n m) s
+    | Zupdate(rf)::s ->
+        zip (update rf (m.norm,m.term)) s
+
+let fapp_stack (m,stk) = zip m stk
+
+(*********************************************************************)
+
+(* The assertions in the functions below are granted because they are
+   called only when m is a constructor, a cofix
+   (strip_update_shift_app), a fix (get_nth_arg) or an abstraction
+   (strip_update_shift, through get_arg). *)
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift head stk =
+  assert (head.norm <> Red);
+  let rec strip_rec h depth = function
+    | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
+    | Zupdate(m)::s ->
+        strip_rec (update m (h.norm,h.term)) depth s
+    | stk -> (depth,stk) in
+  strip_rec head 0 stk
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift_app head stk =
+  assert (head.norm <> Red);
+  let rec strip_rec rstk h depth = function
+    | Zshift(k) as e :: s ->
+        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
+    | (Zapp args :: s) ->
+        strip_rec (Zapp args :: rstk)
+          {norm=h.norm;term=FApp(h,args)} depth s
+    | Zupdate(m)::s ->
+        strip_rec rstk (update m (h.norm,h.term)) depth s
+    | stk -> (depth,List.rev rstk, stk) in
+  strip_rec [] head 0 stk
+
+
+let get_nth_arg head n stk =
+  assert (head.norm <> Red);
+  let rec strip_rec rstk h depth n = function
+    | Zshift(k) as e :: s ->
+        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+    | Zapp args::s' ->
+        let q = Array.length args in
+        if n >= q
+        then
+          strip_rec (Zapp args::rstk)
+            {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
+        else
+          let bef = Array.sub args 0 n in
+          let aft = Array.sub args (n+1) (q-n-1) in
+          let stk' =
+            List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
+          (Some (stk', args.(n)), append_stack aft s')
+    | Zupdate(m)::s ->
+        strip_rec rstk (update m (h.norm,h.term)) depth n s
+    | s -> (None, List.rev rstk @ s) in
+  strip_rec [] head 0 n stk
+
+(* Beta reduction: look for an applied argument in the stack.
+   Since the encountered update marks are removed, h must be a whnf *)
+let get_arg h stk =
+  let (depth,stk') = strip_update_shift h stk in
+  match  decomp_stack stk' with
+      Some (v, s') -> (Some (depth,v), s')
+    | None -> (None, zshift depth stk')
+
+let rec get_args n tys f e stk =
+  match stk with
+      Zupdate r :: s ->
+        let _hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        get_args n tys f e s
+    | Zshift k :: s ->
+        get_args n tys f (subs_shft (k,e)) s
+    | Zapp l :: s ->
+        let na = Array.length l in
+        if n == na then (Inl (subs_cons(l,e)),s)
+        else if n < na then (* more arguments *)
+          let args = Array.sub l 0 n in
+          let eargs = Array.sub l n (na-n) in
+          (Inl (subs_cons(args,e)), Zapp eargs :: s)
+        else (* more lambdas *)
+          let etys = list_skipn na tys in
+          get_args (n-na) etys f (subs_cons(l,e)) s
+    | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
+
+
+(* Iota reduction: extract the arguments to be passed to the Case
+   branches *)
+let rec reloc_rargs_rec depth stk =
+  match stk with
+      Zapp args :: s ->
+        Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s
+    | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s
+    | _ -> stk
+
+let reloc_rargs depth stk =
+  if depth = 0 then stk else reloc_rargs_rec depth stk
+
+let rec drop_parameters depth n stk =
+  match stk with
+      Zapp args::s ->
+        let q = Array.length args in
+        if n > q then drop_parameters depth (n-q) s
+        else if n = q then reloc_rargs depth s
+        else
+          let aft = Array.sub args n (q-n) in
+          reloc_rargs depth (append_stack aft s)
+    | Zshift(k)::s -> drop_parameters (depth-k) n s
+    | [] -> assert (n=0); []
+    | _ -> assert false (* we know that n < stack_args_size(stk) *)
+
+
+(* Iota reduction: expansion of a fixpoint.
+ * Given a fixpoint and a substitution, returns the corresponding
+ * fixpoint body, and the substitution in which it should be
+ * evaluated: its first variables are the fixpoint bodies
+ *
+ * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S)
+ *    -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti)
+ *)
+(* does not deal with FLIFT *)
+let contract_fix_vect fix =
+  let (thisbody, make_body, env, nfix) =
+    match fix with
+      | FFix (((reci,i),(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }),
+	   env, Array.length bds)
+      | FCoFix ((i,(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }),
+	   env, Array.length bds)
+      | _ -> assert false
+  in
+  (subs_cons(Array.init nfix make_body, env), thisbody)
+
+
+(*********************************************************************)
+(* A machine that inspects the head of a term until it finds an
+   atom or a subterm that may produce a redex (abstraction,
+   constructor, cofix, letin, constant), or a neutral term (product,
+   inductive) *)
+let rec knh m stk =
+  match m.term with
+    | FLIFT(k,a) -> knh a (zshift k stk)
+    | FCLOS(t,e) -> knht e t (zupdate m stk)
+    | FLOCKED -> assert false
+    | FApp(a,b) -> knh a (append_stack b (zupdate m stk))
+    | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk)
+    | FFix(((ri,n),(_,_,_)),_) ->
+        (match get_nth_arg m ri.(n) stk with
+             (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk')
+           | (None, stk') -> (m,stk'))
+    | FCast(t,_,_) -> knh t stk
+(* cases where knh stops *)
+    | (FFlex _|FLetIn _|FConstruct _|FEvar _|
+       FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
+        (m, stk)
+
+(* The same for pure terms *)
+and knht e t stk =
+  match t with
+    | App(a,b) ->
+        knht e a (append_stack (mk_clos_vect e b) stk)
+    | Case(ci,p,t,br) ->
+        knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk)
+    | Fix _ -> knh (mk_clos2 e t) stk
+    | Cast(a,_,_) -> knht e a stk
+    | Rel n -> knh (clos_rel e n) stk
+    | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
+       LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
+        (mk_clos2 e t, stk)
+
+
+(************************************************************************)
+
+(* Computes a weak head normal form from the result of knh. *)
+let rec knr info m stk =
+  match m.term with
+  | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
+      (match get_args n tys f e stk with
+          Inl e', s -> knit info e' f s
+        | Inr lam, s -> (lam,s)) 
+  | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
+      (match ref_value_cache info (ConstKey kn) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
+      (match ref_value_cache info (VarKey id) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FFlex(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 ->
+      (match strip_update_shift_app m stk with
+          (depth, args, Zcase(ci,_,br)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            kni info br.(c-1) (rargs@s)
+        | (_, cargs, Zfix(fx,par)::s) ->
+            let rarg = fapp_stack(m,cargs) in
+            let stk' = par @ append_stack [|rarg|] s in
+            let (fxe,fxbd) = contract_fix_vect fx.term in
+            knit info fxe fxbd stk'
+        | (_,args,s) -> (m,args@s))
+  | FCoFix _ when red_set info.i_flags fIOTA ->
+      (match strip_update_shift_app m stk with
+          (_, args, ((Zcase _::_) as stk')) ->
+            let (fxe,fxbd) = contract_fix_vect m.term in
+            knit info fxe fxbd (args@stk')
+        | (_,args,s) -> (m,args@s))
+  | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA ->
+      knit info (subs_cons([|v|],e)) bd stk
+  | _ -> (m,stk)
+
+(* Computes the weak head normal form of a term *)
+and kni info m stk =
+  let (hm,s) = knh m stk in
+  knr info hm s
+and knit info e t stk =
+  let (ht,s) = knht e t stk in
+  knr info ht s
+
+let kh info v stk = fapp_stack(kni info v stk)
+
+(************************************************************************)
+(* Initialization and then normalization *)
+
+(* weak reduction *)
+let whd_val info v =
+  with_stats (lazy (term_of_fconstr (kh info v [])))
+
+let inject = mk_clos (ESID 0)
+
+let whd_stack infos m stk =
+  let k = kni infos m stk in
+  let _ = fapp_stack k in (* to unlock Zupdates! *)
+  k
+
+(* cache of constants: the body is computed only when needed. *)
+type clos_infos = fconstr infos
+
+let create_clos_infos flgs env =
+  create (fun _ -> inject) flgs env
+
+let unfold_reference = ref_value_cache
diff --git a/checker/closure.mli b/checker/closure.mli
new file mode 100644
index 000000000..fa302de64
--- /dev/null
+++ b/checker/closure.mli
@@ -0,0 +1,198 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: closure.mli 9902 2007-06-21 17:01:21Z herbelin $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Esubst
+open Environ
+(*i*)
+
+(* Flags for profiling reductions. *)
+val stats : bool ref
+val share : bool ref
+
+val with_stats: 'a Lazy.t -> 'a
+
+(*s Delta implies all consts (both global (= by
+  [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
+  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+  a LetIn expression is Letin reduction *)
+
+type transparent_state = Idpred.t * Cpred.t
+
+val all_opaque      : transparent_state
+val all_transparent : transparent_state
+
+(* Sets of reduction kinds. *)
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+
+  (* The different kinds of reduction *)
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+
+  (* No reduction at all *)
+  val no_red : reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add : reds -> red_kind -> reds
+
+  (* Removes a reduction kind to a set *)
+  val red_sub : reds -> red_kind -> reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add_transparent : reds -> transparent_state -> reds
+
+  (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
+  val mkflags : red_kind list -> reds
+
+  (* Tests if a reduction kind is set *)
+  val red_set : reds -> red_kind -> bool
+
+  (* Gives the constant list *)
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags : RedFlagsSig
+open RedFlags
+
+val beta               : reds
+val betaiota           : reds
+val betadeltaiota      : reds
+val betaiotazeta       : reds
+val betadeltaiotanolet : reds
+
+val unfold_red : evaluable_global_reference -> reds
+
+(***********************************************************************)
+type table_key =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of int
+
+type 'a infos
+val ref_value_cache: 'a infos -> table_key -> 'a option
+val info_flags: 'a infos -> reds
+val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos
+
+(************************************************************************)
+(*s Lazy reduction. *)
+
+(* [fconstr] is the type of frozen constr *)
+
+type fconstr
+
+(* [fconstr] can be accessed by using the function [fterm_of] and by
+   matching on type [fterm] *)
+
+type fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * cast_kind * fconstr 
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+(************************************************************************)
+(*s A [stack] is a context of arguments, arguments are pushed by
+   [append_stack] one array at a time but popped with [decomp_stack]
+   one by one *)
+
+type stack_member =
+  | Zapp of fconstr array
+  | Zcase of case_info * fconstr * fconstr array
+  | Zfix of fconstr * stack
+  | Zshift of int
+  | Zupdate of fconstr
+
+and stack = stack_member list
+
+val empty_stack : stack
+val append_stack : fconstr array -> stack -> stack
+
+val decomp_stack : stack -> (fconstr * stack) option
+val array_of_stack : stack -> fconstr array
+val stack_assign : stack -> int -> fconstr -> stack
+val stack_args_size : stack -> int
+val stack_tail : int -> stack -> stack
+val stack_nth : stack -> int -> fconstr
+
+(* To lazy reduce a constr, create a [clos_infos] with
+   [create_clos_infos], inject the term to reduce with [inject]; then use
+   a reduction function *)
+
+val inject : constr -> fconstr
+(* mk_atom: prevents a term from being evaluated *)
+val mk_atom : constr -> fconstr
+
+val fterm_of : fconstr -> fterm
+val term_of_fconstr : fconstr -> constr
+val destFLambda :
+  (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+
+(* Global and local constant cache *)
+type clos_infos
+val create_clos_infos : reds -> env -> clos_infos
+
+(* Reduction function *)
+
+(* [whd_val] is for weak head normalization *)
+val whd_val : clos_infos -> fconstr -> constr
+
+(* [whd_stack] performs weak head normalization in a given stack. It
+   stops whenever a reduction is blocked. *)
+val whd_stack :
+  clos_infos -> fconstr -> stack -> fconstr * stack
+
+(* Conversion auxiliary functions to do step by step normalisation *)
+
+(* [unfold_reference] unfolds references in a [fconstr] *)
+val unfold_reference : clos_infos -> table_key -> fconstr option
+
+(* [mind_equiv] checks whether two inductive types are intentionally equal *)
+val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool
+
+(************************************************************************)
+(*i This is for lazy debug *)
+
+val lift_fconstr      : int -> fconstr -> fconstr
+val lift_fconstr_vect : int -> fconstr array -> fconstr array
+
+val mk_clos      : fconstr subs -> constr -> fconstr
+val mk_clos_vect : fconstr subs -> constr array -> fconstr array
+val mk_clos_deep :
+  (fconstr subs -> constr -> fconstr) ->
+   fconstr subs -> constr -> fconstr
+
+val kni: clos_infos -> fconstr -> stack -> fconstr * stack
+val knr: clos_infos -> fconstr -> stack -> fconstr * stack
+
+val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
+val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
+
+(* End of cbn debug section i*)
diff --git a/checker/declarations.ml b/checker/declarations.ml
new file mode 100644
index 000000000..d5c34d92b
--- /dev/null
+++ b/checker/declarations.ml
@@ -0,0 +1,608 @@
+open Util
+open Names
+open Term
+
+(* Bytecode *)
+type values
+type reloc_table
+type to_patch_substituted
+(*Retroknowledge *)
+type action
+type retroknowledge
+
+type engagement = ImpredicativeSet
+
+
+type polymorphic_arity = {
+  poly_param_levels : Univ.universe option list;
+  poly_level : Univ.universe;
+}
+
+type constant_type =
+  | NonPolymorphicType of constr
+  | PolymorphicArity of rel_context * polymorphic_arity
+
+
+
+type substitution_domain = 
+    MSI of mod_self_id 
+  | MBI of mod_bound_id
+  | MPI of module_path
+
+module Umap = Map.Make(struct 
+			 type t = substitution_domain
+			 let compare = Pervasives.compare
+		       end)
+
+type resolver
+
+type substitution = (module_path * resolver option) Umap.t
+type 'a subst_fun = substitution -> 'a -> 'a
+
+let empty_subst = Umap.empty
+
+let add_msid msid mp =
+  Umap.add (MSI msid) (mp,None)
+let add_mbid mbid mp =
+  Umap.add (MBI mbid) (mp,None)
+let add_mp mp1 mp2  =
+  Umap.add (MPI mp1) (mp2,None)
+
+let map_msid msid mp = add_msid msid mp empty_subst
+let map_mbid mbid mp = add_mbid mbid mp empty_subst
+let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst
+
+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) as mp2 ->
+	begin
+	  try  
+	    let mp',resolve = Umap.find (MPI mp2) sub in
+              mp',resolve
+	  with Not_found ->    
+	    let mp1',resolve = aux mp1 in
+	      MPdot (mp1',l),resolve
+	end
+    | _ -> raise Not_found
+ in
+  try
+    Some (aux mp) 
+  with Not_found -> None
+
+
+
+let subst_mp0 sub mp = (* 's like subst *)
+ let rec aux mp =
+  match mp with
+    | MPself sid -> fst (Umap.find (MSI sid) sub)
+    | MPbound bid -> fst (Umap.find (MBI bid) sub)
+    | MPdot (mp1,l) as mp2 ->
+	begin
+	  try fst (Umap.find (MPI mp2) sub)
+	  with Not_found -> MPdot (aux mp1,l)
+	end
+
+    | _ -> 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
+   | Some mp' -> make_con mp' dir l
+
+let subst_con0 sub con =
+ let mp,dir,l = repr_con con in
+  match subst_mp0 sub mp with
+      None -> None
+    | Some mp' ->
+	let con' = make_con mp' dir l in
+        Some (Const con')
+
+let rec map_kn f f' c = 
+  let func = map_kn f f' in
+    match c with
+      | Const kn -> 
+	  (match f' kn with
+	       None -> c
+	     | Some const ->const)
+      | Ind (kn,i) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	      Ind (kn',i))
+      | Construct ((kn,i),j) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	       Construct ((kn',i),j))
+      | Case (ci,p,ct,l) -> 
+	  let ci_ind =
+            let (kn,i) = ci.ci_ind in
+              (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
+	  let p' = func p in
+	  let ct' = func ct in
+	  let l' = array_smartmap func l in
+	    if (ci.ci_ind==ci_ind && p'==p 
+		&& l'==l && ct'==ct)then c
+	    else 
+	      Case ({ci with ci_ind = ci_ind},
+		     p',ct', l')  
+      | Cast (ct,k,t) -> 
+	  let ct' = func ct in
+	  let t'= func t in
+	    if (t'==t && ct'==ct) then c 
+	    else Cast (ct', k, t')
+      | Prod (na,t,ct) -> 
+	  let ct' = func ct in
+	  let t'= func t in
+	    if (t'==t && ct'==ct) then c 
+	    else Prod (na, t', ct')
+      | Lambda (na,t,ct) -> 
+	  let ct' = func ct in
+	  let t'= func t in
+	    if (t'==t && ct'==ct) then c 
+	    else Lambda (na, t', ct')
+      | LetIn (na,b,t,ct) -> 
+	  let ct' = func ct in
+	  let t'= func t in
+	  let b'= func b in
+	    if (t'==t && ct'==ct && b==b') then c 
+	    else LetIn (na, b', t', ct')
+      | App (ct,l) -> 
+	  let ct' = func ct in
+	  let l' = array_smartmap func l in
+	    if (ct'== ct && l'==l) then c
+	    else App (ct',l')
+      | Evar (e,l) -> 
+	  let l' = array_smartmap func l in
+	    if (l'==l) then c
+	    else Evar (e,l')
+      | Fix (ln,(lna,tl,bl)) ->
+	  let tl' = array_smartmap func tl in
+	  let bl' = array_smartmap func bl in
+	    if (bl == bl'&& tl == tl') then c  
+	    else Fix (ln,(lna,tl',bl'))
+      | CoFix(ln,(lna,tl,bl)) ->
+	  let tl' = array_smartmap func tl in
+	  let bl' = array_smartmap func bl in
+	    if (bl == bl'&& tl == tl') then c  
+	    else CoFix (ln,(lna,tl',bl'))
+      | _ -> c
+
+let subst_mps sub = 
+  map_kn (subst_kn0 sub) (subst_con0 sub)
+
+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 = kn in
+  let mp'' = replace_mp_in_mp mpfrom mpto mp in
+    if mp==mp'' then kn
+    else (mp'', dir, l)
+
+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 join (subst1 : substitution) (subst2 : substitution) =
+  let apply_subst (sub : substitution) key (mp,_) =
+      match subst_mp0 sub mp with
+	  None -> mp,None
+	| Some mp' -> mp',None in
+  let subst = Umap.mapi (apply_subst subst2) subst1 in
+    (Umap.fold Umap.add subst2 subst)
+
+let subst_key subst1 subst2 =
+  let replace_in_key key mp sub=
+    let newkey = 
+      match key with
+	| MPI mp1 -> 
+	    begin
+	      match subst_mp0 subst1 mp1 with
+		| None -> None
+		| Some mp2 -> Some (MPI mp2)
+	    end
+	| _ -> None
+    in
+      match newkey with
+	| None -> Umap.add key mp sub
+	| Some mpi -> Umap.add mpi mp sub
+  in
+    Umap.fold replace_in_key subst2 empty_subst
+
+let update_subst_alias subst1 subst2 =
+ let subst_inv key (mp,_) sub =
+    let newmp = 
+      match key with 
+	| MBI msid -> Some (MPbound msid)
+	| MSI msid -> Some (MPself msid)
+	| _ -> None
+    in
+      match newmp with
+	| None -> sub
+	| Some mpi -> match mp with 
+	    | MPbound mbid -> Umap.add (MBI mbid) (mpi,None) sub
+	    | MPself msid -> Umap.add (MSI msid) (mpi,None) sub
+	    | _ ->  Umap.add (MPI mp) (mpi,None) sub
+  in 
+  let subst_mbi = Umap.fold subst_inv subst2 empty_subst in
+  let alias_subst key (mp,_) sub=
+    let newkey = 
+      match key with
+	| MPI mp1 -> 
+	    begin
+	      match subst_mp0 subst_mbi mp1 with
+		| None -> None
+		| Some mp2 -> Some (MPI mp2)
+	    end
+	| _ -> None
+    in
+      match newkey with
+	| None -> Umap.add key (mp,None) sub
+	| Some mpi -> Umap.add mpi (mp,None) sub
+  in
+    Umap.fold alias_subst subst1 empty_subst
+
+let join_alias (subst1 : substitution) (subst2 : substitution) =
+  let apply_subst (sub : substitution) key (mp,_) =
+      match subst_mp0 sub mp with
+	  None -> mp,None
+	| Some mp' -> mp',None in
+  Umap.mapi (apply_subst subst2) subst1 
+
+
+
+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))
+
+let force_constr = force subst_mps 
+
+type constr_substituted = constr substituted
+
+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 : constant_type;
+    const_body_code : to_patch_substituted;
+   (* const_type_code : Cemitcodes.to_patch; *)
+    const_constraints : Univ.constraints;
+    const_opaque : bool; 
+    const_inline : bool}
+
+let subst_rel_declaration sub (id,copt,t as x) =
+  let copt' = Option.smartmap (subst_mps sub) copt in
+  let t' = subst_mps sub t in
+  if copt == copt' & t == t' then x else (id,copt',t')
+
+let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+let subst_recarg sub r = match r with
+  | Norec | Mrec _  -> r
+  | Imbr (kn,i) -> let kn' = subst_kn sub kn in
+      if kn==kn' then r else Imbr (kn',i)
+
+type wf_paths = recarg Rtree.t
+
+let mk_norec = Rtree.mk_node Norec [||]
+
+let mk_paths r recargs =
+  Rtree.mk_node r
+    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
+
+let dest_recarg p = fst (Rtree.dest_node p)
+
+let dest_subterms p =
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
+
+let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
+
+(**********************************************************************)
+(* 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 monomorphic_inductive_arity = {
+  mind_user_arity : constr;
+  mind_sort : sorts;
+}
+
+type inductive_arity = 
+| Monomorphic of monomorphic_inductive_arity
+| Polymorphic of polymorphic_arity
+
+type one_inductive_body = {
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity context of [Ii] with parameters: [forall params, Ui] *)
+    mind_arity_ctxt : rel_context;
+
+ (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
+    mind_arity : inductive_arity;
+
+ (* 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 : constr array;
+
+(* Derived datas *)
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : constr 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 :  reloc_table; 
+  }
+
+type mutual_inductive_body = {
+
+  (* 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 : Univ.constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
+
+let subst_arity sub = function
+| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+
+(* TODO: should be changed to non-coping after Term.subst_mps *)
+let subst_const_body sub cb = {
+    const_hyps = (assert (cb.const_hyps=[]); []);
+    const_body = Option.map (subst_constr_subst sub) cb.const_body;
+    const_type = subst_arity sub cb.const_type;
+    const_body_code = (*Cemitcodes.subst_to_patch_subst sub*) cb.const_body_code;
+    (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
+    const_constraints = cb.const_constraints;
+    const_opaque = cb.const_opaque;
+    const_inline = cb.const_inline} 
+
+let subst_arity sub = function
+| Monomorphic s ->
+    Monomorphic {
+      mind_user_arity = subst_mps sub s.mind_user_arity;
+      mind_sort = s.mind_sort;
+    }
+| Polymorphic s as x -> x
+
+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 (subst_mps sub) mbp.mind_nf_lc;
+    mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
+    mind_arity = subst_arity sub mbp.mind_arity;
+    mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
+    mind_nrealargs = mbp.mind_nrealargs;
+    mind_kelim = mbp.mind_kelim;
+    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.map (subst_kn sub) mib.mind_equiv }
+
+(* Modules *)
+
+type structure_field_body = 
+  | SFBconst of constant_body
+  | SFBmind of mutual_inductive_body
+  | SFBmodule of module_body
+  | SFBalias of module_path * Univ.constraints option
+  | SFBmodtype of module_type_body
+
+and structure_body = (label * structure_field_body) list
+
+and struct_expr_body =
+  | SEBident of module_path
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
+  | SEBstruct of mod_self_id * structure_body
+  | SEBapply of struct_expr_body * struct_expr_body
+      * Univ.constraints
+  | SEBwith of struct_expr_body * with_declaration_body
+
+and with_declaration_body =
+    With_module_body of identifier list * module_path * Univ.constraints
+  | With_definition_body of  identifier list * constant_body
+        
+and module_body = 
+    { mod_expr : struct_expr_body option;
+      mod_type : struct_expr_body option;
+      mod_constraints : Univ.constraints;
+      mod_alias : substitution;
+      mod_retroknowledge : action list}
+
+and module_type_body = 
+    { typ_expr : struct_expr_body;
+      typ_strength : module_path option;
+      typ_alias : substitution}
+
+	
+let subst_with_body sub = function
+  | With_module_body(id,mp,cst) ->
+      With_module_body(id,subst_mp sub mp,cst)
+  | With_definition_body(id,cb) ->
+      With_definition_body( id,subst_const_body sub cb)
+
+let rec subst_modtype sub mtb =
+  let typ_expr' = subst_struct_expr sub mtb.typ_expr in
+    if typ_expr'==mtb.typ_expr then
+      mtb
+    else
+      { mtb with 
+	  typ_expr = typ_expr'}
+	
+and subst_structure sub sign = 
+  let subst_body  = function
+      SFBconst cb -> 
+	SFBconst (subst_const_body sub cb)
+    | SFBmind mib -> 
+	SFBmind (subst_mind sub mib)
+    | SFBmodule mb -> 
+	SFBmodule (subst_module sub mb)
+    | SFBmodtype mtb -> 
+	SFBmodtype (subst_modtype sub mtb)
+    | SFBalias (mp,cst) ->
+	SFBalias (subst_mp sub mp,cst)
+  in
+    List.map (fun (l,b) -> (l,subst_body b)) sign
+
+and subst_module  sub mb =
+  let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in
+  (* This is similar to the previous case. In this case we have
+     a module M in a signature that is knows to be equivalent to a module M'
+     (because the signature is "K with Module M := M'") and we are substituting
+     M' with some M''. *)
+  let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in
+  let mb_alias = join_alias mb.mod_alias sub in
+    if mtb'==mb.mod_type && mb.mod_expr == me' 
+      && mb_alias == mb.mod_alias
+    then mb else
+      { mod_expr = me';
+	mod_type=mtb'; 
+	mod_constraints=mb.mod_constraints;
+	mod_alias = mb_alias;
+	mod_retroknowledge=mb.mod_retroknowledge}
+
+
+and subst_struct_expr sub = function
+    | SEBident mp -> SEBident (subst_mp sub  mp)
+    | SEBfunctor (msid, mtb, meb') -> 
+	SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb')
+    | SEBstruct (msid,str)->
+	SEBstruct(msid, subst_structure sub str)
+    | SEBapply (meb1,meb2,cst)->
+	SEBapply(subst_struct_expr sub meb1,
+		 subst_struct_expr sub meb2,
+		 cst)
+    | SEBwith (meb,wdb)-> 
+	SEBwith(subst_struct_expr sub meb,
+		subst_with_body sub wdb)
+ 
+
+let subst_signature_msid msid mp = 
+  subst_structure (map_msid msid mp)
diff --git a/checker/declarations.mli b/checker/declarations.mli
new file mode 100644
index 000000000..2145343d3
--- /dev/null
+++ b/checker/declarations.mli
@@ -0,0 +1,205 @@
+open Util
+open Names
+open Term
+
+(* Bytecode *)
+type values
+type reloc_table
+type to_patch_substituted
+(*Retroknowledge *)
+type action
+type retroknowledge
+
+(* Engagements *)
+
+type engagement = ImpredicativeSet
+
+(* Constants *)
+
+type polymorphic_arity = {
+  poly_param_levels : Univ.universe option list;
+  poly_level : Univ.universe;
+}
+
+type constant_type =
+  | NonPolymorphicType of constr
+  | PolymorphicArity of rel_context * polymorphic_arity
+
+type constr_substituted 
+val force_constr : constr_substituted -> constr
+val from_val : constr -> constr_substituted
+
+type constant_body = {
+    const_hyps : section_context; (* New: younger hyp at top *)
+    const_body : constr_substituted option;
+    const_type : constant_type;
+    const_body_code : to_patch_substituted;
+    const_constraints : Univ.constraints;
+    const_opaque : bool; 
+    const_inline : bool}
+
+(* Mutual inductives *)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+type wf_paths = recarg Rtree.t
+
+val mk_norec : wf_paths
+val mk_paths : recarg -> wf_paths list array -> wf_paths
+val dest_subterms : wf_paths -> wf_paths list array
+
+type monomorphic_inductive_arity = {
+  mind_user_arity : constr;
+  mind_sort : sorts;
+}
+
+type inductive_arity = 
+| Monomorphic of monomorphic_inductive_arity
+| Polymorphic of polymorphic_arity
+
+type one_inductive_body = {
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity context of [Ii] with parameters: [forall params, Ui] *)
+    mind_arity_ctxt : rel_context;
+
+ (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
+    mind_arity : inductive_arity;
+
+ (* 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 : constr array;
+
+(* Derived datas *)
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : constr 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 :  reloc_table; 
+  }
+
+type mutual_inductive_body = {
+
+  (* 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 : Univ.constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
+
+(* Modules *)
+
+type substitution
+
+type structure_field_body = 
+  | SFBconst of constant_body
+  | SFBmind of mutual_inductive_body
+  | SFBmodule of module_body
+  | SFBalias of module_path * Univ.constraints option
+  | SFBmodtype of module_type_body
+
+and structure_body = (label * structure_field_body) list
+
+and struct_expr_body =
+  | SEBident of module_path
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
+  | SEBstruct of mod_self_id * structure_body
+  | SEBapply of struct_expr_body * struct_expr_body
+      * Univ.constraints
+  | SEBwith of struct_expr_body * with_declaration_body
+
+and with_declaration_body =
+    With_module_body of identifier list * module_path * Univ.constraints
+  | With_definition_body of  identifier list * constant_body
+        
+and module_body = 
+    { mod_expr : struct_expr_body option;
+      mod_type : struct_expr_body option;
+      mod_constraints : Univ.constraints;
+      mod_alias : substitution;
+      mod_retroknowledge : action list}
+
+and module_type_body = 
+    { typ_expr : struct_expr_body;
+      typ_strength : module_path option;
+      typ_alias : substitution}
+
+(* Substitutions *)
+
+type 'a subst_fun = substitution -> 'a -> 'a
+
+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 add_mp   : module_path -> module_path -> substitution -> substitution
+val map_msid : mod_self_id -> module_path -> substitution
+val map_mbid : mod_bound_id -> module_path -> substitution
+val map_mp   : module_path -> module_path -> substitution
+
+val subst_const_body : constant_body subst_fun
+val subst_mind : mutual_inductive_body subst_fun
+val subst_modtype : substitution -> module_type_body -> module_type_body
+val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
+val subst_structure : substitution -> structure_body -> structure_body
+val subst_signature_msid :
+  mod_self_id -> module_path -> structure_body -> structure_body
+
+val join : substitution -> substitution -> substitution
+val join_alias : substitution -> substitution -> substitution
+val update_subst_alias : substitution -> substitution -> substitution
+val subst_key : substitution -> substitution -> substitution
diff --git a/checker/environ.ml b/checker/environ.ml
new file mode 100644
index 000000000..58f08bdd5
--- /dev/null
+++ b/checker/environ.ml
@@ -0,0 +1,206 @@
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+
+type globals = {
+  env_constants : constant_body Cmap.t;
+  env_inductives : mutual_inductive_body KNmap.t;
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body MPmap.t;
+  env_alias : module_path MPmap.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;
+    env_imports : Digest.t MPmap.t }
+
+let empty_env = {
+  env_globals =
+  { env_constants = Cmap.empty;
+    env_inductives = KNmap.empty;
+    env_modules = MPmap.empty;
+    env_modtypes = MPmap.empty;
+    env_alias = MPmap.empty };
+  env_named_context = [];
+  env_rel_context = [];
+  env_stratification =
+  { env_universes = Univ.initial_universes;
+    env_engagement = None};
+  env_imports = MPmap.empty }
+
+let engagement env = env.env_stratification.env_engagement
+let universes env = env.env_stratification.env_universes
+let named_context env = env.env_named_context
+let rel_context env = env.env_rel_context
+
+let set_engagement c env =
+  match env.env_stratification.env_engagement with
+    | Some c' -> if c=c' then env else error "Incompatible engagement"
+    | None ->
+        { env with env_stratification =
+          { env.env_stratification with env_engagement = Some c } }
+
+(* Digests *)
+
+let add_digest env dp digest =
+  { env with env_imports = MPmap.add (MPfile dp) digest env.env_imports }
+
+let lookup_digest env dp =
+  MPmap.find (MPfile dp) env.env_imports
+
+(* Rel context *)
+let lookup_rel n env =
+  let rec lookup_rel n sign =
+    match n, sign with
+      | 1, decl :: _ -> decl
+      | n, _ :: sign -> lookup_rel (n-1) sign
+      | _, []        -> raise Not_found in
+  lookup_rel n env.env_rel_context
+
+let push_rel d env =
+    { env with
+      env_rel_context = d :: env.env_rel_context }
+
+let push_rel_context ctxt x = 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, lift i t)) lna typarray in
+  Array.fold_left (fun e assum -> push_rel assum e) env ctxt
+
+(* Named context *)
+
+let push_named d env = 
+(*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
+  assert (env.env_rel_context = []); *)
+    { env with  
+      env_named_context = d :: env.env_named_context }
+
+let lookup_named id env =
+  let rec lookup_named id = function
+    | (id',_,_ as decl) :: _ when id=id' -> decl
+    | _ :: sign -> lookup_named id sign
+    | [] -> raise Not_found in
+  lookup_named id env.env_named_context
+
+(* A local const is evaluable if it is defined  *)
+
+let named_type id env =
+  let (_,_,t) = lookup_named id env in t
+
+(* Universe constraints *)
+let add_constraints c env =
+  if c == Constraint.empty then 
+    env 
+  else
+    let s = env.env_stratification in
+    { env with env_stratification = 
+      { s with env_universes = merge_constraints c s.env_universes } }
+
+(* Global constants *)
+
+let lookup_constant kn env =
+  Cmap.find kn env.env_globals.env_constants
+
+let add_constant kn cs env =
+  let new_constants = 
+    Cmap.add kn cs env.env_globals.env_constants in
+  let new_globals = 
+    { env.env_globals with 
+	env_constants = new_constants } in 
+  { env with env_globals = new_globals }
+
+(* constant_type gives the type of a constant *)
+let constant_type env kn =
+  let cb = lookup_constant kn env in
+  cb.const_type  
+
+type const_evaluation_result = NoBody | Opaque
+
+exception NotEvaluableConst of const_evaluation_result
+
+let constant_value env kn =
+  let cb = lookup_constant kn env in
+  if cb.const_opaque then raise (NotEvaluableConst Opaque);
+  match cb.const_body with
+    | Some l_body -> force_constr l_body
+    | None -> raise (NotEvaluableConst NoBody)
+
+let constant_opt_value env cst =
+  try Some (constant_value env cst)
+  with NotEvaluableConst _ -> None
+
+(* A global const is evaluable if it is defined and not opaque *)
+let evaluable_constant cst env =
+  try let _  = constant_value env cst in true
+  with Not_found | NotEvaluableConst _ -> false
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  KNmap.find kn env.env_globals.env_inductives
+
+let rec scrape_mind env kn = 
+  match (lookup_mind kn env).mind_equiv with
+    | None -> kn
+    | Some kn' -> scrape_mind env kn'
+
+let add_mind kn mib env =
+  let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
+  let new_globals = 
+    { env.env_globals with 
+	env_inductives = new_inds } in
+  { env with env_globals = new_globals }
+
+let rec mind_equiv env (kn1,i1) (kn2,i2) =
+  let rec equiv kn1 kn2 =
+    kn1 = kn2 ||
+    scrape_mind env kn1 = scrape_mind env kn2 in
+  i1 = i2 && equiv kn1 kn2
+
+
+(* Modules *)
+
+let add_modtype ln mtb env = 
+  let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
+  let new_globals = 
+    { env.env_globals with 
+	env_modtypes = new_modtypes } in
+  { env with env_globals = new_globals }
+
+let shallow_add_module mp mb env = 
+  let new_mods = MPmap.add mp mb env.env_globals.env_modules in
+  let new_globals = 
+    { env.env_globals with 
+	env_modules = new_mods } in
+  { env with env_globals = new_globals }
+
+let register_alias mp1 mp2 env =
+  let new_alias =  MPmap.add mp1 mp2 env.env_globals.env_alias in
+  let new_globals = 
+    { env.env_globals with 
+	env_alias = new_alias } in
+    { env with env_globals = new_globals }
+
+let rec scrape_alias mp env = 
+  try
+    let mp1 = MPmap.find mp env.env_globals.env_alias in
+      scrape_alias mp1 env
+  with
+      Not_found -> mp
+
+let lookup_module mp env = 
+  MPmap.find mp env.env_globals.env_modules
+
+let lookup_modtype ln env = 
+  MPmap.find ln env.env_globals.env_modtypes
+
+let lookup_alias mp env =
+  MPmap.find mp env.env_globals.env_alias
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
new file mode 100644
index 000000000..305aa4e58
--- /dev/null
+++ b/checker/indtypes.ml
@@ -0,0 +1,575 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: indtypes.ml 10296 2007-11-07 11:02:42Z barras $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Inductive
+open Reduction
+open Typeops
+open Pp
+open Declarations
+open Environ
+
+let prkn kn =
+  let (mp,_,l) = repr_kn kn in
+  str(string_of_mp mp ^ "." ^ string_of_label l)
+let prcon c =
+  let (mp,_,l) = repr_con c in
+  str(string_of_mp mp ^ "." ^ string_of_label l)
+
+(* Same as noccur_between but may perform reductions.
+   Could be refined more...  *)
+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'
+   else None
+
+let is_constructor_head t =
+  match fst(decompose_app t) with
+  | Rel _ -> true
+  | _ -> false
+
+let conv_ctxt_prefix env (ctx1:rel_context) ctx2 =
+  let rec chk env rctx1 rctx2 =
+    match rctx1, rctx2 with
+        (_,None,ty1 as d1)::rctx1', (_,None,ty2)::rctx2' ->
+          conv env ty1 ty2;
+          chk (push_rel d1 env) rctx1' rctx2'
+      | (_,Some bd1,ty1 as d1)::rctx1', (_,Some bd2,ty2)::rctx2' ->
+          conv env ty1 ty2;
+          conv env bd1 bd2;
+          chk (push_rel d1 env) rctx1' rctx2'
+      | [],_ -> ()
+      | _ -> failwith "non convertible contexts" in
+  chk env (List.rev ctx1) (List.rev ctx2)
+
+(************************************************************************)
+(* Various well-formedness check for inductive declarations            *)
+
+(* Errors related to inductive constructions *)
+type inductive_error =
+  | NonPos of env * constr * constr
+  | NotEnoughArgs of env * constr * constr
+  | NotConstructor of env * constr * constr
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier
+  | SameNamesOverlap of identifier list
+  | NotAnArity of identifier
+  | BadEntry
+
+exception InductiveError of inductive_error
+
+(************************************************************************)
+(************************************************************************)
+
+(* Typing the arities and constructor types *)
+
+let rec sorts_of_constr_args env t =
+  let t = whd_betadeltaiota_nolet env t in
+  match t with
+    | Prod (name,c1,c2) ->
+        let varj = infer_type env c1 in
+	let env1 = push_rel (name,None,c1) env in
+	varj :: sorts_of_constr_args env1 c2
+    | LetIn (name,def,ty,c) ->
+        let env1 = push_rel (name,Some def,ty) env in
+	sorts_of_constr_args env1 c
+    | _ when is_constructor_head t -> []
+    | _ -> anomaly "infos_and_sort: not a positive constructor"
+
+
+(* Prop and Set are small *)
+let is_small_sort = function
+  | Prop _ -> true
+  | _ -> false
+
+let is_logic_sort s = (s = Prop Null)
+
+(* [infos] is a sequence of pair [islogic,issmall] for each type in
+   the product of a constructor or arity *)
+
+let is_small_constr infos = List.for_all (fun s -> is_small_sort s) infos
+let is_logic_constr infos = List.for_all (fun s -> is_logic_sort s) infos
+
+(* An inductive definition is a "unit" if it has only one constructor
+   and that all arguments expected by this constructor are 
+   logical, this is the case for equality, conjunction of logical properties 
+*)
+let is_unit constrsinfos =
+  match constrsinfos with  (* One info = One constructor *)
+   | [|constrinfos|] -> is_logic_constr constrinfos 
+   | [||] -> (* type without constructors *) true
+   | _ -> false
+
+let small_unit constrsinfos =
+  let issmall = array_for_all is_small_constr constrsinfos 
+  and isunit = is_unit constrsinfos in
+  issmall, isunit
+
+(* Computing the levels of polymorphic inductive types
+
+   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 that summarize all the other constraints. 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 extract_level (_,_,_,lc,lev) =
+  (* Enforce that the level is not in Prop if more than two constructors *)
+  if Array.length lc >= 2 then sup base_univ lev else lev
+
+let inductive_levels arities inds =
+  let levels = Array.map pi3 arities in
+  let cstrs_levels = Array.map extract_level inds in
+  (* Take the transitive closure of the system of constructors *)
+  (* level constraints and remove the recursive dependencies *)
+  solve_constraints_system levels cstrs_levels
+
+
+let check_kind env ar u =
+  if snd (dest_prod env ar) = Sort(Type u) then ()
+  else failwith "not the correct sort"
+
+let check_polymorphic_arity env params par =
+  let pl = par.poly_param_levels in
+  let rec check_p env pl params =
+    match pl, params with
+        Some u::pl, (na,None,ty)::params ->
+          check_kind env ty u;
+          check_p (push_rel (na,None,ty) env) pl params
+      | None::pl,d::params -> check_p (push_rel d env) pl params
+      | [], _ -> ()
+      | _ -> failwith "check_poly: not the right number of params" in
+  check_p env pl (List.rev params)
+
+(* check information related to inductive arity *)
+let typecheck_arity env params inds =
+  let nparamargs = rel_context_nhyps params in
+  let check_arity arctxt = function
+      Monomorphic mar ->
+        let ar = mar.mind_user_arity in
+        let _ = infer_type env ar in
+        conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar;
+        ar
+    | Polymorphic par ->
+        check_polymorphic_arity env params par;
+        it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in
+  let env_arities =
+    Array.fold_left
+      (fun env_ar ind ->
+        let ar_ctxt = ind.mind_arity_ctxt in
+        let _ = check_ctxt env ar_ctxt in
+        conv_ctxt_prefix env params ar_ctxt;
+        (* Arities (with params) are typed-checked here *)
+        let arity = check_arity ar_ctxt ind.mind_arity in
+        (* mind_nrealargs *)
+        if ind.mind_nrealargs <> rel_context_nhyps ar_ctxt - nparamargs then
+             failwith "bad number of real inductive arguments";
+	(* We do not need to generate the universe of full_arity; if
+	   later, after the validation of the inductive definition,
+	   full_arity is used as argument or subject to cast, an
+	   upper universe will be generated *)
+	let id = ind.mind_typename in
+	let env_ar' = push_rel (Name id, None, arity) env_ar in
+        env_ar')
+      env
+      inds in
+  env_arities
+
+(* Allowed eliminations *)
+
+let check_predicativity env s small level =
+  match s, engagement env with
+      Type u, _ ->
+        let u' = fresh_local_univ () in
+        let cst =
+          merge_constraints (enforce_geq u' u Constraint.empty)
+            (universes env) in
+        if not (check_geq cst u' level) then
+          failwith "impredicative Type inductive type"
+    | Prop Pos, Some ImpredicativeSet -> ()
+    | Prop Pos, _ ->
+        if not small then failwith "impredicative Set inductive type"
+    | Prop Null,_ -> ()
+
+
+let sort_of_ind = function
+    Monomorphic mar -> mar.mind_sort
+  | Polymorphic par -> Type par.poly_level
+
+let all_sorts = [InProp;InSet;InType]
+let small_sorts = [InProp;InSet]
+let logical_sorts = [InProp]
+
+let allowed_sorts issmall isunit s =
+  match family_of_sort s with
+  (* Type: all elimination allowed *)
+  | InType -> all_sorts
+
+  (* Small Set is predicative: all elimination allowed *)
+  | InSet when issmall -> all_sorts
+
+  (* Large Set is necessarily impredicative: forbids large elimination *)
+  | InSet -> small_sorts
+
+  (* Unitary/empty Prop: elimination to all sorts are realizable *)
+  (* unless the type is large. If it is large, forbids large elimination *)
+  (* which otherwise allows to simulate the inconsistent system Type:Type *)
+  | InProp when isunit -> if issmall then all_sorts else small_sorts
+
+  (* Other propositions: elimination only to Prop *)
+  | InProp -> logical_sorts
+
+
+
+let compute_elim_sorts env_ar params mib arity lc =
+  let inst = extended_rel_list 0 params in
+  let env_params = push_rel_context params env_ar in
+  let lc = Array.map
+    (fun c ->
+      hnf_prod_applist env_params (lift (rel_context_length params) c) inst)
+    lc in
+  let s = sort_of_ind arity in
+  let infos = Array.map (sorts_of_constr_args env_params) lc in
+  let (small,unit) = small_unit infos in
+  (* We accept recursive unit types... *)
+  let unit = unit && mib.mind_ntypes = 1 in
+  (* compute the max of the sorts of the products of the constructor type *)
+  let level = max_inductive_sort
+    (Array.concat (Array.to_list (Array.map Array.of_list infos))) in
+  check_predicativity env_ar s small level;
+  allowed_sorts small unit s
+
+
+let typecheck_one_inductive env params mib mip =
+  (* mind_typename and mind_consnames not checked *)
+  (* mind_reloc_tbl, mind_nb_constant, mind_nb_args not checked (VM) *)
+  (* mind_arity_ctxt, mind_arity, mind_nrealargs DONE (typecheck_arity) *)
+  (* mind_user_lc *)
+  let _ = Array.map (infer_type env) mip.mind_user_lc in
+  (* mind_nf_lc *)
+  let _ = Array.map (infer_type env) mip.mind_nf_lc in
+  array_iter2 (conv env) mip.mind_nf_lc mip.mind_user_lc;
+  (* mind_consnrealdecls *)
+  let check_cons_args c n =
+    let ctx,_ = decompose_prod_assum c in
+    if n <> rel_context_length ctx - rel_context_length params then
+      failwith "bad number of real constructor arguments" in
+  array_iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls;
+  (* mind_kelim: checked by positivity criterion ? *)
+  let sorts =
+    compute_elim_sorts env params mib mip.mind_arity mip.mind_nf_lc in
+  if List.exists (fun s -> not (List.mem s sorts)) mip.mind_kelim then
+    failwith "elimination not allowed";
+  (* mind_recargs: checked by positivity criterion *)
+  ()
+
+(************************************************************************)
+(************************************************************************)
+(* Positivity *)
+
+type ill_formed_ind =
+  | LocalNonPos of int
+  | LocalNotEnoughArgs of int
+  | LocalNotConstructor
+  | LocalNonPar of int * int
+
+exception IllFormedInd of ill_formed_ind
+
+(* [mind_extract_params mie] extracts the params from an inductive types
+   declaration, and checks that they are all present (and all the same)
+   for all the given types. *)
+
+let mind_extract_params = decompose_prod_n_assum
+
+let explain_ind_err ntyp env0 nbpar c err = 
+  let (lpar,c') = mind_extract_params nbpar c in
+  let env = push_rel_context lpar env0 in
+  match err with
+    | LocalNonPos kt -> 
+	raise (InductiveError (NonPos (env,c',Rel (kt+nbpar))))
+    | LocalNotEnoughArgs kt -> 
+	raise (InductiveError 
+		 (NotEnoughArgs (env,c',Rel (kt+nbpar))))
+    | LocalNotConstructor ->
+	raise (InductiveError 
+		 (NotConstructor (env,c',Rel (ntyp+nbpar))))
+    | LocalNonPar (n,l) ->
+	raise (InductiveError 
+		 (NonPar (env,c',n,Rel (nbpar-n+1), Rel (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 =
+  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"
+
+(* Conclusion of constructors: check the inductive type is called with
+   the expected parameters *)
+let check_correct_par (env,n,ntypes,_) hyps l largs =
+  let nparams = rel_context_nhyps hyps in
+  let largs = Array.of_list largs in
+  if Array.length largs < nparams then 
+    raise (IllFormedInd (LocalNotEnoughArgs l));
+  let (lpar,largs') = array_chop nparams largs in
+  let nhyps = List.length hyps in
+  let rec check k index = function
+    | [] -> ()
+    | (_,Some _,_)::hyps -> check k (index+1) hyps
+    | _::hyps ->
+        match whd_betadeltaiota env lpar.(k) with
+	  | Rel w when w = index -> check (k-1) (index+1) hyps
+	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
+  in check (nparams-1) (n-nhyps) hyps;
+  if not (array_for_all (noccur_between n ntypes) largs') then 
+    failwith_non_pos_vect n ntypes largs'
+
+(* Arguments of constructor: check the number of recursive parameters nrecp.
+    the first parameters which are constant in recursive arguments 
+    n is the current depth, nmr is the maximum number of possible 
+    recursive parameters *)
+
+let check_rec_par (env,n,_,_) hyps nrecp largs = 
+  let (lpar,_) = list_chop nrecp largs in
+  let rec find index = 
+    function 
+      | ([],_) -> ()
+      | (_,[]) ->
+          failwith "number of recursive parameters cannot be greater than the number of parameters."
+      | (lp,(_,Some _,_)::hyps) -> find (index-1) (lp,hyps)
+      | (p::lp,_::hyps) ->
+          (match whd_betadeltaiota env p with
+	    | Rel w when w = index -> find (index-1) (lp,hyps)
+            | _ -> failwith "bad number of recursive parameters")
+  in find (n-1) (lpar,List.rev hyps)
+
+let lambda_implicit_lift n a =
+  let lambda_implicit a = Lambda(Anonymous,Evar(0,[||]),a) in
+  iterate lambda_implicit n (lift n a)
+
+(* This removes global parameters of the inductive types in lc (for
+   nested inductive types only ) *)
+let abstract_mind_lc env ntyps npars lc = 
+  if npars = 0 then 
+    lc
+  else 
+    let make_abs = 
+      list_tabulate
+	(function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps 
+    in 
+    Array.map (substl make_abs) lc
+
+(* [env] is the typing environment
+   [n] is the dB of the last inductive type
+   [ntypes] is the number of inductive types in the definition
+     (i.e. range of inductives is [n; n+ntypes-1])
+   [lra] is the list of recursive tree of each variable
+ *) 
+let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
+ (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+
+let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
+  let auxntyp = 1 in
+  let specif = lookup_mind_specif env mi in
+  let env' =
+    push_rel (Anonymous,None,
+              hnf_prod_applist env (type_of_inductive env specif) lpar) env in
+  let ra_env' = 
+    (Imbr mi,(Rtree.mk_rec_calls 1).(0)) ::
+    List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
+  (* New index of the inductive types *)
+  let newidx = n + auxntyp in
+  (env', newidx, ntypes, ra_env')
+
+(* The recursive function that checks positivity and builds the list
+   of recursive arguments *)
+let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
+  let lparams = rel_context_length hyps in
+  (* check the inductive types occur positively in [c] *)
+  let rec check_pos (env, n, ntypes, ra_env as ienv) c = 
+    let x,largs = decompose_app (whd_betadeltaiota env c) in
+      match x with
+	| Prod (na,b,d) ->
+	    assert (largs = []);
+            (match weaker_noccur_between env n ntypes b with
+		None -> failwith_non_pos_list n ntypes [b]
+              | Some b ->
+	          check_pos (ienv_push_var ienv (na, b, mk_norec)) d)
+	| Rel k ->
+            (try
+              let (ra,rarg) = List.nth ra_env (k-1) in 
+	      (match ra with
+                  Mrec _ -> check_rec_par ienv hyps nrecp largs
+		|  _ -> ());
+	      if not (List.for_all (noccur_between n ntypes) largs)
+	      then failwith_non_pos_list n ntypes largs
+	      else rarg
+            with Failure _ | Invalid_argument _ -> 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)
+	| err -> 
+	    if noccur_between n ntypes x &&
+              List.for_all (noccur_between n ntypes) largs 
+	    then mk_norec
+	    else failwith_non_pos_list n ntypes (x::largs)
+
+  (* accesses to the environment are not factorised, but is it worth it? *)
+  and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) =
+    let (mib,mip) = lookup_mind_specif env mi in
+    let auxnpar = mib.mind_nparams_rec in
+    let (lpar,auxlargs) =
+      try list_chop auxnpar largs 
+      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
+      (* If the inductive appears in the args (non params) then the
+	 definition is not positive. *)
+      if not (List.for_all (noccur_between n ntypes) auxlargs) then
+	raise (IllFormedInd (LocalNonPos n));
+      (* We do not deal with imbricated mutual inductive types *)
+      let auxntyp = mib.mind_ntypes in 
+	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+	(* The nested inductive type with parameters removed *)
+	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+	  (* Extends the environment with a variable corresponding to
+	     the inductive def *)
+	let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
+	  (* Parameters expressed in env' *)
+	let lpar' = List.map (lift auxntyp) lpar in
+	let irecargs = 
+	  (* fails if the inductive type occurs non positively *)
+	  (* when substituted *) 
+	  Array.map 
+	    (function c -> 
+	      let c' = hnf_prod_applist env' c lpar' in 
+		check_constructors ienv' false c') 
+	    auxlcvect in 
+	(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)
+	    
+  (* check the inductive types occur positively in the products of C, if
+     check_head=true, also check the head corresponds to a constructor of
+     the ith type *) 
+	    
+  and check_constructors ienv check_head c = 
+    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = 
+      let x,largs = decompose_app (whd_betadeltaiota env c) in
+	match x with
+          | Prod (na,b,d) -> 
+	      assert (largs = []);
+              let recarg = check_pos ienv b in 
+              let ienv' = ienv_push_var ienv (na,b,mk_norec) in
+		check_constr_rec ienv' (recarg::lrec) d
+		  
+	  | hd ->
+	      if check_head then
+		if hd = Rel (n+ntypes-i-1) then
+		  check_correct_par ienv hyps (ntypes-i) largs
+		else
+		  raise (IllFormedInd LocalNotConstructor)
+	      else
+		if not (List.for_all (noccur_between n ntypes) largs)
+              then raise (IllFormedInd (LocalNonPos n));
+	      List.rev lrec
+    in check_constr_rec ienv [] c
+  in
+  let irecargs =
+    Array.map
+      (fun c ->
+        let _,rawc = mind_extract_params lparams c in
+          try
+	    check_constructors ienv true rawc
+          with IllFormedInd err -> 
+            explain_ind_err (ntypes-i) env lparams c err)
+      indlc
+  in mk_paths (Mrec i) irecargs
+
+let check_subtree (t1:'a) (t2:'a) =
+  if not (Rtree.compare_rtree (fun t1 t2 ->
+    let l1 = fst(Rtree.dest_node t1) in
+    let l2 = fst(Rtree.dest_node t2) in
+    if l1 = Norec || l1 = l2 then 0 else -1)
+    t1 t2) then
+    failwith "bad recursive trees"
+(* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*)
+
+let check_positivity env_ar params nrecp inds =
+  let ntypes = Array.length inds in
+  let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in
+  let lra_ind = List.rev (Array.to_list rc) in
+  let lparams = rel_context_length params in
+  let check_one i mip =
+    let ra_env =
+      list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
+    let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
+      check_positivity_one ienv params nrecp i mip.mind_nf_lc 
+  in
+  let irecargs = Array.mapi check_one inds in 
+  let wfp = Rtree.mk_rec irecargs in
+  array_iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp
+
+(************************************************************************)
+(************************************************************************)
+
+let check_inductive env kn mib =
+  Flags.if_verbose msgnl (str "  checking ind: " ++ prkn kn);
+  (* check mind_constraints: should be consistent with env *)
+  let env = add_constraints mib.mind_constraints env in
+  (* check mind_record : TODO ? check #constructor = 1 ? *)
+  (* check mind_finite : always OK *)
+  (* check mind_ntypes *)
+  if Array.length mib.mind_packets <> mib.mind_ntypes then
+    error "not the right number of packets";
+  (* check mind_hyps: should be empty *)
+  if mib.mind_hyps <> empty_named_context then
+    error "section context not empty";
+  (* check mind_params_ctxt *)
+  let params = mib.mind_params_ctxt in
+  let _ = check_ctxt env params in
+  (* check mind_nparams *)
+  if rel_context_nhyps params <> mib.mind_nparams then
+    error "number the right number of parameters";
+  (* mind_packets *)
+  (*  - check arities *)
+  let env_ar = typecheck_arity env params mib.mind_packets in
+  (*  - check constructor types *)
+  Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets;
+  (* check mind_nparams_rec: positivity condition *)
+  check_positivity env_ar params mib.mind_nparams_rec mib.mind_packets;
+  (* check mind_equiv... *)
+  if mib.mind_equiv <> None then
+    msg_warning (str"TODO: mind_equiv not checked");
+  (* Now we can add the inductive *)
+  add_mind kn mib env
+
diff --git a/checker/indtypes.mli b/checker/indtypes.mli
new file mode 100644
index 000000000..b920315ab
--- /dev/null
+++ b/checker/indtypes.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: indtypes.mli 9831 2007-05-17 18:55:42Z herbelin $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Typeops
+open Declarations
+open Environ
+(*i*)
+
+val prkn : kernel_name -> Pp.std_ppcmds
+val prcon : constant -> Pp.std_ppcmds
+
+(*s The different kinds of errors that may result of a malformed inductive
+  definition. *)
+
+(* Errors related to inductive constructions *)
+type inductive_error =
+  | NonPos of env * constr * constr
+  | NotEnoughArgs of env * constr * constr
+  | NotConstructor of env * constr * constr
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier
+  | SameNamesOverlap of identifier list
+  | NotAnArity of identifier
+  | BadEntry
+
+exception InductiveError of inductive_error
+
+(*s The following function does checks on inductive declarations. *)
+
+val check_inductive : env -> mutual_inductive -> mutual_inductive_body -> env
diff --git a/checker/inductive.ml b/checker/inductive.ml
new file mode 100644
index 000000000..c2301777d
--- /dev/null
+++ b/checker/inductive.ml
@@ -0,0 +1,913 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: inductive.ml 10172 2007-10-04 13:02:03Z herbelin $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Type_errors
+open Declarations
+open Environ
+
+let inductive_of_constructor = fst
+let index_of_constructor = snd
+let ith_constructor_of_inductive ind i = (ind,i)
+
+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 = lookup_mind kn env in
+  if tyi >= Array.length mib.mind_packets then
+    error "Inductive.lookup_mind_specif: invalid inductive index";
+  (mib, mib.mind_packets.(tyi))
+
+let find_rectype env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match t with
+  | Ind ind -> (ind, l)
+  | _ -> raise Not_found
+
+let find_inductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match t with
+    | Ind ind
+        when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+let find_coinductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match t with
+    | Ind ind
+        when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+let inductive_params (mib,_) = mib.mind_nparams
+
+(************************************************************************)
+
+(* 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 = Ind (mind,ntypes-k-1) in 
+  list_tabulate make_Ik ntypes
+
+(* Instantiate inductives in constructor type *)
+let constructor_instantiate mind mib c =
+  let s = ind_subst mind mib in
+  substl s c
+
+let instantiate_params full t args sign =
+  let fail () = 
+    anomaly "instantiate_params: type, ctxt and args mismatch" in
+  let (rem_args, subs, ty) =
+    fold_rel_context
+      (fun (_,copt,_) (largs,subs,ty) ->
+        match (copt, largs, ty) with
+          | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
+          | (Some b,_,LetIn(_,_,_,t))    -> (largs, (substl subs b)::subs, t)
+	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
+	  | _                       -> fail ())
+      sign
+      ~init:(args,[],t) 
+  in
+  if rem_args <> [] then fail();
+  substl subs ty
+
+let instantiate_partial_params = instantiate_params false
+
+let full_inductive_instantiate mib params sign =
+  let dummy = Prop Null in
+  let t = mkArity (sign,dummy) in
+  fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
+
+let full_constructor_instantiate ((mind,_),(mib,_),params) =
+  let inst_ind = constructor_instantiate mind mib in
+  (fun t ->
+    instantiate_params true (inst_ind t) params mib.mind_params_ctxt)
+
+(************************************************************************)
+(************************************************************************)
+
+(* Functions to build standard types related to inductive *)
+
+
+let number_of_inductives mib = Array.length mib.mind_packets
+let number_of_constructors mip = Array.length mip.mind_consnames
+
+(* 
+Computing the actual sort of an applied or partially applied inductive type:
+
+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 sort_as_univ = function
+| Type u -> u
+| Prop Null -> neutral_univ
+| Prop Pos -> base_univ
+
+let cons_subst u su subst =
+  try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
+  with Not_found -> (u, su) :: subst
+
+let actualize_decl_level env lev t =
+  let sign,s = dest_arity env t in
+  mkArity (sign,lev)
+
+let polymorphism_on_non_applied_parameters = false
+
+(* Bind expected levels of parameters to actual levels *)
+(* Propagate the new levels in the signature *)
+let rec make_subst env = function
+  | (_,Some _,_ as t)::sign, exp, args ->
+      let ctx,subst = make_subst env (sign, exp, args) in
+      t::ctx, subst
+  | d::sign, None::exp, args ->
+      let args = match args with _::args -> args | [] -> [] in
+      let ctx,subst = make_subst env (sign, exp, args) in
+      d::ctx, subst
+  | d::sign, Some u::exp, a::args ->
+      (* We recover the level of the argument, but we don't change the *)
+      (* level in the corresponding type in the arity; this level in the *)
+      (* arity is a global level which, at typing time, will be enforce *)
+      (* to be greater than the level of the argument; this is probably *)
+      (* a useless extra constraint *)
+      let s = sort_as_univ (snd (dest_arity env a)) in
+      let ctx,subst = make_subst env (sign, exp, args) in
+      d::ctx, cons_subst u s subst
+  | (na,None,t as d)::sign, Some u::exp, [] ->
+      (* No more argument here: we instantiate the type with a fresh level *)
+      (* which is first propagated to the corresponding premise in the arity *)
+      (* (actualize_decl_level), then to the conclusion of the arity (via *)
+      (* the substitution) *)
+      let ctx,subst = make_subst env (sign, exp, []) in
+      if polymorphism_on_non_applied_parameters then
+	let s = fresh_local_univ () in
+	let t = actualize_decl_level env (Type s) t in
+	(na,None,t)::ctx, cons_subst u s subst
+      else
+	d::ctx, subst
+  | sign, [], _ ->
+      (* Uniform parameters are exhausted *)
+      sign,[]
+  | [], _, _ ->
+      assert false
+
+let instantiate_universes env ctx ar argsorts =
+  let args = Array.to_list argsorts in
+  let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in
+  let level = subst_large_constraints subst ar.poly_level in
+  ctx,
+  if is_empty_univ level then Prop Null
+  else if is_base_univ level then Prop Pos
+  else Type level
+
+let type_of_inductive_knowing_parameters env mip paramtyps =
+  match mip.mind_arity with
+  | Monomorphic s ->
+      s.mind_user_arity
+  | Polymorphic ar ->
+      let ctx = List.rev mip.mind_arity_ctxt in
+      let ctx,s = instantiate_universes env ctx ar paramtyps in
+      mkArity (List.rev ctx,s)
+
+(* Type of a (non applied) inductive type *)
+
+let type_of_inductive env (_,mip) =
+  type_of_inductive_knowing_parameters env mip [||]
+
+(* The max of an array of universes *)
+
+let cumulate_constructor_univ u = function
+  | Prop Null -> u
+  | Prop Pos -> sup base_univ u
+  | Type u' -> sup u u'
+
+let max_inductive_sort =
+  Array.fold_left cumulate_constructor_univ neutral_univ
+
+(************************************************************************)
+(* Type of a constructor *)
+
+let type_of_constructor cstr (mib,mip) =
+  let ind = inductive_of_constructor cstr in
+  let specif = mip.mind_user_lc in
+  let i = index_of_constructor cstr in
+  let nconstr = Array.length mip.mind_consnames in
+  if i > nconstr then error "Not enough constructors in the type";
+  constructor_instantiate (fst ind) mib specif.(i-1)
+
+let arities_of_specif kn (mib,mip) = 
+  let specif = mip.mind_nf_lc in
+  Array.map (constructor_instantiate kn mib) specif
+
+
+
+(************************************************************************)
+
+let error_elim_expln kp ki =
+  match kp,ki with
+  | (InType | InSet), InProp -> NonInformativeToInformative
+  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
+  | _ -> WrongArity
+
+(* Type of case predicates *)
+
+(* Get type of inductive, with parameters instantiated *)
+
+let inductive_sort_family mip =
+  match mip.mind_arity with
+   | Monomorphic s -> family_of_sort s.mind_sort 
+   | Polymorphic _ -> InType
+
+let mind_arity mip =
+  mip.mind_arity_ctxt, inductive_sort_family mip
+
+let get_instantiated_arity (mib,mip) params =
+  let sign, s = mind_arity mip in
+  full_inductive_instantiate mib params sign, s
+
+let elim_sorts (_,mip) = mip.mind_kelim
+
+let rel_list n m = 
+  let rec reln l p = 
+    if p>m then l else reln (Rel(n+p)::l) (p+1)
+  in 
+  reln [] 1
+
+let build_dependent_inductive ind (_,mip) params =
+  let nrealargs = mip.mind_nrealargs in
+  applist 
+    (Ind ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs))
+
+(* This exception is local *)
+exception LocalArity of (sorts_family * sorts_family * arity_error) option
+
+let check_allowed_sort ksort specif =
+  if not (List.exists ((=) ksort) (elim_sorts specif)) then 
+    let s = inductive_sort_family (snd specif) in
+    raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
+
+let is_correct_arity env c (p,pj) ind specif params = 
+  let arsign,_ = get_instantiated_arity specif params in
+  let rec srec env pt ar =
+    let pt' = whd_betadeltaiota env pt in
+    match pt', ar with
+      | Prod (na1,a1,t), (_,None,a1')::ar' ->
+          (try conv env a1 a1'
+          with NotConvertible -> raise (LocalArity None));
+          srec (push_rel (na1,None,a1) env) t ar'
+      | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
+          let ksort = match (whd_betadeltaiota env a2) with
+            | Sort s -> family_of_sort s 
+	    | _ -> raise (LocalArity None) in
+	  let dep_ind = build_dependent_inductive ind specif params in 
+          (try conv env a1 dep_ind
+          with NotConvertible -> raise (LocalArity None));
+	  check_allowed_sort ksort specif;
+	  true
+      | Sort s', [] ->
+	  check_allowed_sort (family_of_sort s') specif;
+	  false
+      | _ ->
+	  raise (LocalArity None)
+  in 
+  try srec env pj (List.rev arsign)
+  with LocalArity kinds ->
+    error_elim_arity env ind (elim_sorts specif) c (p,pj) kinds
+
+
+(************************************************************************)
+(* Type of case branches *)
+
+(* [p] is the predicate, [i] is the constructor number (starting from 0),
+   and [cty] is the type of the constructor (params not instantiated) *)
+let build_branches_type ind (_,mip as specif) params dep p =
+  let build_one_branch i cty =
+    let typi = full_constructor_instantiate (ind,specif,params) cty in
+    let (args,ccl) = decompose_prod_assum typi in
+    let nargs = rel_context_length args in
+    let (_,allargs) = decompose_app ccl in
+    let (lparams,vargs) = list_chop (inductive_params specif) allargs in
+    let cargs =
+      if dep then
+        let cstr = ith_constructor_of_inductive ind (i+1) in
+        let dep_cstr =
+          applist (Construct cstr,lparams@extended_rel_list 0 args) in
+        vargs @ [dep_cstr]
+      else
+        vargs in
+    let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
+    it_mkProd_or_LetIn base args in
+  Array.mapi build_one_branch mip.mind_nf_lc
+
+(* [p] is the predicate, [c] is the match object, [realargs] is the
+   list of real args of the inductive type *)
+let build_case_type dep p c realargs =
+  let args = if dep then realargs@[c] else realargs in
+  beta_appvect p (Array.of_list args)
+
+let type_case_branches env (ind,largs) (p,pj) c =
+  let specif = lookup_mind_specif env ind in 
+  let nparams = inductive_params specif in
+  let (params,realargs) = list_chop nparams largs in
+  let dep = is_correct_arity env c (p,pj) ind specif params in
+  let lc = build_branches_type ind specif params dep p in
+  let ty = build_case_type dep p c realargs in
+  (lc, ty)
+
+
+(************************************************************************)
+(* Checking the case annotation is relevent *)
+
+let check_case_info env indsp ci =
+  let (mib,mip) = lookup_mind_specif env indsp in
+  if
+    not (mind_equiv env indsp ci.ci_ind) or
+    (mib.mind_nparams <> ci.ci_npar) or
+    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
+  then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
+
+(************************************************************************)
+(************************************************************************)
+
+(* Guard conditions for fix and cofix-points *)
+
+(* Check if t is a subterm of Rel n, and gives its specification, 
+   assuming lst already gives index of
+   subterms with corresponding specifications of recursive arguments *)
+
+(* A powerful notion of subterm *)
+
+(* To each inductive definition corresponds an array describing the
+   structure of recursive arguments for each constructor, we call it
+   the recursive spec of the type (it has type recargs vect).  For
+   checking the guard, we start from the decreasing argument (Rel n)
+   with its recursive spec.  During checking the guardness condition,
+   we collect patterns variables corresponding to subterms of n, each
+   of them with its recursive spec.  They are organised in a list lst
+   of type (int * recargs) list which is sorted with respect to the
+   first argument.
+*)
+
+(*************************************************************)
+(* Environment annotated with marks on recursive arguments *)
+
+(* tells whether it is a strict or loose subterm *)
+type size = Large | Strict
+
+(* merging information *)
+let size_glb s1 s2 =
+  match s1,s2 with
+      Strict, Strict -> Strict
+    | _ -> Large
+
+(* possible specifications for a term:
+   - Not_subterm: when the size of a term is not related to the
+     recursive argument of the fixpoint
+   - Subterm: when the term is a subterm of the recursive argument
+       the wf_paths argument specifies which subterms are recursive
+   - Dead_code: when the term has been built by elimination over an
+       empty type
+ *)
+
+type subterm_spec =
+    Subterm of (size * wf_paths)
+  | Dead_code
+  | Not_subterm
+
+let spec_of_tree t =
+  if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t)
+
+let subterm_spec_glb =
+  let glb2 s1 s2 =
+    match s1,s2 with
+        _, Dead_code -> s1
+      | Dead_code, _ -> s2
+      | Not_subterm, _ -> Not_subterm
+      | _, Not_subterm -> Not_subterm
+      | Subterm (a1,t1), Subterm (a2,t2) ->
+          if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1)
+          (* branches do not return objects with same spec *)
+          else Not_subterm in
+  Array.fold_left glb2 Dead_code
+          
+type guard_env =
+  { env     : env;
+    (* dB of last fixpoint *)
+    rel_min : int;
+    (* inductive of recarg of each fixpoint *)
+    inds    : inductive array;
+    (* the recarg information of inductive family *)
+    recvec  : wf_paths array;
+    (* dB of variables denoting subterms *)
+    genv    : subterm_spec list;
+  }
+
+let make_renv env minds recarg (kn,tyi) =
+  let mib = lookup_mind kn env in
+  let mind_recvec =
+    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+  { env = env;
+    rel_min = recarg+2;
+    inds = minds;
+    recvec = mind_recvec;
+    genv = [Subterm(Large,mind_recvec.(tyi))] }
+
+let push_var renv (x,ty,spec) =
+  { renv with 
+    env = push_rel (x,None,ty) renv.env;
+    rel_min = renv.rel_min+1;
+    genv = spec:: renv.genv }
+
+let assign_var_spec renv (i,spec) =
+  { renv with genv = list_assign renv.genv (i-1) spec }
+
+let push_var_renv renv (x,ty) =
+  push_var renv (x,ty,Not_subterm)
+
+(* Fetch recursive information about a variable p *)
+let subterm_var p renv = 
+  try List.nth renv.genv (p-1)
+  with Failure _ | Invalid_argument _ -> Not_subterm
+
+(* Add a variable and mark it as strictly smaller with information [spec]. *)
+let add_subterm renv (x,a,spec) =
+  push_var renv (x,a,spec_of_tree spec)
+
+let push_ctxt_renv renv ctxt =
+  let n = rel_context_length ctxt in
+  { renv with 
+    env = push_rel_context ctxt renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+let push_fix_renv renv (_,v,_ as recdef) =
+  let n = Array.length v in
+  { renv with
+    env = push_rec_types recdef renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+
+(******************************)
+(* Computing the recursive subterms of a term (propagation of size
+   information through Cases). *)
+
+(*
+   c is a branch of an inductive definition corresponding to the spec
+   lrec.  mind_recvec is the recursive spec of the inductive
+   definition of the decreasing argument n.
+
+   case_branches_specif renv lrec lc will pass the lambdas
+   of c corresponding to pattern variables and collect possibly new
+   subterms variables and returns the bodies of the branches with the
+   correct envs and decreasing args.
+*)
+
+let lookup_subterms env ind =
+  let (_,mip) = lookup_mind_specif env ind in
+  mip.mind_recargs
+
+(*********************************)
+
+(* Propagation of size information through Cases: if the matched
+   object is a recursive subterm then compute the information
+   associated to its own subterms.
+   Rq: if branch is not eta-long, then the recursive information
+   is not propagated to the missing abstractions *)
+let case_branches_specif renv c_spec ind lbr = 
+  let rec push_branch_args renv lrec c = 
+    match lrec with
+        ra::lr ->
+          let c' = whd_betadeltaiota renv.env c in
+          (match c' with
+              Lambda(x,a,b) ->
+                let renv' = push_var renv (x,a,ra) in
+                push_branch_args renv' lr b
+            | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
+                (renv,c'))
+      | [] -> (renv, c) in
+  match c_spec with
+      Subterm (_,t) ->
+        let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Dead_code -> 
+        let t = dest_subterms (lookup_subterms renv.env ind) in
+        let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
+
+(* [subterm_specif renv t] computes the recursive structure of [t] and
+   compare its size with the size of the initial recursive argument of
+   the fixpoint we are checking. [renv] collects such information
+   about variables.
+*)
+
+let rec subterm_specif renv t = 
+  (* maybe reduction is not always necessary! *)
+  let f,l = decompose_app (whd_betadeltaiota renv.env t) in
+  match f with 
+    | Rel k -> subterm_var k renv
+
+    | Case (ci,_,c,lbr) ->
+        if Array.length lbr = 0 then Dead_code
+        else
+          let c_spec = subterm_specif renv c in
+          let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in
+          let stl  =
+            Array.map (fun (renv',br') -> subterm_specif renv' br')
+              lbr_spec in
+          subterm_spec_glb stl
+	       
+    | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+(* when proving that the fixpoint f(x)=e is less than n, it is enough
+   to prove that e is less than n assuming f is less than n
+   furthermore when f is applied to a term which is strictly less than
+   n, one may assume that x itself is strictly less than n
+*)
+        let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+        let oind =
+          let env' = push_rel_context ctxt renv.env in
+          try Some(fst(find_inductive env' clfix))
+          with Not_found -> None in
+        (match oind with
+            None -> Not_subterm (* happens if fix is polymorphic *)
+          | Some ind ->
+              let nbfix = Array.length typarray in
+              let recargs = lookup_subterms renv.env ind in
+              (* pushing the fixpoints *)
+              let renv' = push_fix_renv renv recdef in
+              let renv' =
+                (* Why Strict here ? To be general, it could also be
+                   Large... *)
+                assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
+              let decrArg = recindxs.(i) in 
+              let theBody = bodies.(i)   in
+              let nbOfAbst = decrArg+1 in
+              let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+              (* pushing the fix parameters *)
+              let renv'' = push_ctxt_renv renv' sign in
+              let renv'' =
+                if List.length l < nbOfAbst then renv''
+                else
+                  let theDecrArg  = List.nth l decrArg in
+	          let arg_spec    = subterm_specif renv theDecrArg in
+                  assign_var_spec renv'' (1, arg_spec) in
+	      subterm_specif renv'' strippedBody)
+
+    | Lambda (x,a,b) -> 
+        assert (l=[]);
+        subterm_specif (push_var_renv renv (x,a)) b
+
+    (* Metas and evars are considered OK *)
+    | (Meta _|Evar _) -> Dead_code
+
+    (* Other terms are not subterms *)
+    | _ -> Not_subterm
+
+
+(* Check term c can be applied to one of the mutual fixpoints. *)
+let check_is_subterm renv c = 
+  match subterm_specif renv c with
+    Subterm (Strict,_) | Dead_code -> true
+  |  _ -> false
+
+(************************************************************************)
+
+exception FixGuardError of env * guard_error
+
+let error_illegal_rec_call renv fx arg =
+  let (_,le_vars,lt_vars) =
+    List.fold_left
+      (fun (i,le,lt) sbt ->
+        match sbt with
+            (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt)
+          | (Subterm(Large,_)) -> (i+1, i::le, lt)
+          | _ -> (i+1, le ,lt))
+      (1,[],[]) renv.genv in
+  raise (FixGuardError (renv.env,
+                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+
+let error_partial_apply renv fx =
+  raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
+
+(* Check if [def] is a guarded fixpoint body with decreasing arg.
+   given [recpos], the decreasing arguments of each mutually defined
+   fixpoint. *)
+let check_one_fix renv recpos def =
+  let nfi = Array.length recpos in 
+
+  (* Checks if [t] only make valid recursive calls *)
+  let rec check_rec_call renv t = 
+    (* if [t] does not make recursive calls, it is guarded: *)
+    if noccur_with_meta renv.rel_min nfi t then ()
+    else
+      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
+      match f with
+        | Rel p -> 
+            (* Test if [p] is a fixpoint (recursive call) *) 
+	    if renv.rel_min <= p & p < renv.rel_min+nfi then
+              begin
+                List.iter (check_rec_call renv) l;
+                (* the position of the invoked fixpoint: *) 
+	        let glob = renv.rel_min+nfi-1-p in
+                (* the decreasing arg of the rec call: *)
+	        let np = recpos.(glob) in
+                if List.length l <= np then error_partial_apply renv glob
+                else
+                  (* Check the decreasing arg is smaller *)
+                  let z = List.nth l np in
+	          if not (check_is_subterm renv z) then
+                    error_illegal_rec_call renv glob z
+              end
+            else
+              begin
+                match pi2 (lookup_rel p renv.env) with
+                | None ->
+                    List.iter (check_rec_call renv) l
+                | Some c ->
+                    try List.iter (check_rec_call renv) l
+                    with FixGuardError _ -> check_rec_call renv (applist(c,l))
+              end
+
+        | Case (ci,p,c_0,lrest) ->
+            List.iter (check_rec_call renv) (c_0::p::l);
+            (* compute the recarg information for the arguments of
+               each branch *)
+            let c_spec = subterm_specif renv c_0 in
+            let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in
+            Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+
+        (* Enables to traverse Fixpoint definitions in a more intelligent
+           way, ie, the rule :
+           if - g = Fix g/p := [y1:T1]...[yp:Tp]e &
+              - f is guarded with respect to the set of pattern variables S 
+                in a1 ... am        &
+              - f is guarded with respect to the set of pattern variables S 
+                in T1 ... Tp        &
+              - ap is a sub-term of the formal argument of f &
+              - f is guarded with respect to the set of pattern variables
+                S+{yp} in e
+           then f is guarded with respect to S in (g a1 ... am).
+           Eduardo 7/9/98 *)
+
+        | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+            List.iter (check_rec_call renv) l;
+            Array.iter (check_rec_call renv) typarray;
+            let decrArg = recindxs.(i) in
+            let renv' = push_fix_renv renv recdef in 
+            if (List.length l < (decrArg+1)) then
+	      Array.iter (check_rec_call renv') bodies
+            else 
+              Array.iteri
+                (fun j body ->
+                  if i=j then
+                    let theDecrArg  = List.nth l decrArg in
+	            let arg_spec = subterm_specif renv theDecrArg in
+	            check_nested_fix_body renv' (decrArg+1) arg_spec body
+                  else check_rec_call renv' body)
+                bodies
+
+        | Const kn -> 
+            if evaluable_constant kn renv.env then 
+              try List.iter (check_rec_call renv) l
+              with (FixGuardError _ ) ->
+	        check_rec_call renv(applist(constant_value renv.env kn, l))
+	    else List.iter (check_rec_call renv) l
+
+        (* The cases below simply check recursively the condition on the
+           subterms *)
+        | Cast (a,_, b) -> 
+            List.iter (check_rec_call renv) (a::b::l)
+
+        | Lambda (x,a,b) ->
+            List.iter (check_rec_call renv) (a::l);
+            check_rec_call (push_var_renv renv (x,a)) b
+
+        | Prod (x,a,b) -> 
+            List.iter (check_rec_call renv) (a::l);
+            check_rec_call (push_var_renv renv (x,a)) b
+
+        | CoFix (i,(_,typarray,bodies as recdef)) ->
+            List.iter (check_rec_call renv) l;
+	    Array.iter (check_rec_call renv) typarray;
+	    let renv' = push_fix_renv renv recdef in
+	    Array.iter (check_rec_call renv') bodies
+
+        | (Ind _ | Construct _ | Sort _) ->
+            List.iter (check_rec_call renv) l
+
+        | Var id ->
+            begin
+              match pi2 (lookup_named id renv.env) with
+              | None ->
+                  List.iter (check_rec_call renv) l
+              | Some c ->
+                  try List.iter (check_rec_call renv) l
+                  with (FixGuardError _) -> check_rec_call renv (applist(c,l))
+            end
+
+        (* l is not checked because it is considered as the meta's context *)
+        | (Evar _ | Meta _) -> ()
+
+        | (App _|LetIn _) -> assert false (* beta zeta reduction *)
+
+  and check_nested_fix_body renv decr recArgsDecrArg body =
+    if decr = 0 then
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+    else
+      match body with
+	| Lambda (x,a,b) ->
+	    check_rec_call renv a;
+            let renv' = push_var_renv renv (x,a) in
+	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+	| _ -> anomaly "Not enough abstractions in fix body"
+
+  in
+  check_rec_call renv def
+
+
+let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
+  let nbfix = Array.length bodies in 
+  if nbfix = 0
+    or Array.length nvect <> nbfix 
+    or Array.length types <> nbfix
+    or Array.length names <> nbfix
+    or bodynum < 0
+    or bodynum >= nbfix
+  then anomaly "Ill-formed fix term";
+  let fixenv = push_rec_types recdef env in
+  let raise_err 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 = 
+    (* check fi does not appear in the k+1 first abstractions, 
+       gives the type of the k+1-eme abstraction (must be an inductive)  *)
+    let rec check_occur env n def = 
+      match (whd_betadeltaiota env def) with
+        | Lambda (x,a,b) -> 
+	    if noccur_with_meta n nbfix a then
+	      let env' = push_rel (x, None, a) env in
+              if n = k+1 then
+                (* get the inductive type of the fixpoint *)
+                let (mind, _) = 
+                  try find_inductive env a 
+                  with Not_found ->
+		    raise_err 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 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 (minds, rdef) = inductive_of_mutfix env fix in
+  for i = 0 to Array.length bodies - 1 do
+    let (fenv,body) = rdef.(i) in
+    let renv = make_renv fenv minds nvect.(i) minds.(i) in
+    try check_one_fix renv nvect body
+    with FixGuardError (fixenv,err) ->
+      error_ill_formed_rec_body fixenv err names i
+  done
+
+(*
+let cfkey = Profile.declare_profile "check_fix";;
+let check_fix env fix = Profile.profile3 cfkey check_fix env fix;;
+*)
+
+(************************************************************************)
+(* Co-fixpoints. *)
+
+exception CoFixGuardError of env * guard_error
+
+let anomaly_ill_typed () =
+  anomaly "check_one_cofix: too many arguments applied to constructor"
+
+let rec codomain_is_coind env c =
+  let b = whd_betadeltaiota env c in
+  match b with
+    | Prod (x,a,b) ->
+	codomain_is_coind (push_rel (x, None, a) env) b 
+    | _ -> 
+	(try find_coinductive env b
+        with Not_found ->
+	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
+
+let check_one_cofix env nbfix def deftype = 
+  let rec check_rec_call env alreadygrd n vlra  t =
+    if not (noccur_with_meta n nbfix t) then
+      let c,args = decompose_app (whd_betadeltaiota env t) in
+      match c with 
+	| Rel p when  n <= p && p < n+nbfix ->
+	    (* recursive call: must be guarded and no nested recursive
+               call allowed *)
+            if not alreadygrd then
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
+            else if not(List.for_all (noccur_with_meta n nbfix) args) then
+	      raise (CoFixGuardError (env,NestedRecursiveOccurrences))
+		 
+	| Construct (_,i as cstr_kn)  ->
+            let lra = vlra.(i-1) in 
+            let mI = inductive_of_constructor cstr_kn in
+	    let (mib,mip) = lookup_mind_specif env mI in
+            let realargs = list_skipn mib.mind_nparams args in
+            let rec process_args_of_constr = function
+              | (t::lr), (rar::lrar) -> 
+                  if rar = mk_norec then
+                    if noccur_with_meta n nbfix t
+                    then process_args_of_constr (lr, lrar)
+                    else raise (CoFixGuardError
+		                 (env,RecCallInNonRecArgOfConstructor t))
+                  else
+                    let spec = dest_subterms rar in
+                    check_rec_call env true n spec t;
+                    process_args_of_constr (lr, lrar)
+              | [],_ -> ()
+              | _ -> anomaly_ill_typed () 
+            in process_args_of_constr (realargs, lra)
+		 
+	| Lambda (x,a,b) ->
+	     assert (args = []);
+            if noccur_with_meta n nbfix a then
+              let env' = push_rel (x, None, a) env in
+              check_rec_call env' alreadygrd (n+1)  vlra b
+            else 
+	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
+	      
+	| CoFix (j,(_,varit,vdefs as recdef)) ->
+            if (List.for_all (noccur_with_meta n nbfix) args)
+            then 
+              let nbfix = Array.length vdefs in
+	      if (array_for_all (noccur_with_meta n nbfix) varit) then
+		let env' = push_rec_types recdef env in
+		(Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs;
+		 List.iter (check_rec_call env alreadygrd n vlra) args)
+              else 
+		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
+	    else
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
+
+	| Case (_,p,tm,vrest) ->
+            if (noccur_with_meta n nbfix p) then
+              if (noccur_with_meta n nbfix tm) then
+		if (List.for_all (noccur_with_meta n nbfix) args) then
+		  Array.iter (check_rec_call env alreadygrd n vlra) vrest
+		else 
+		  raise (CoFixGuardError (env,RecCallInCaseFun c))
+              else 
+		raise (CoFixGuardError (env,RecCallInCaseArg c))
+            else 
+	      raise (CoFixGuardError (env,RecCallInCasePred c))
+              
+	| Meta _ -> ()
+        | Evar _ ->
+	    List.iter (check_rec_call env alreadygrd n vlra) args
+	      
+	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in 
+
+  let (mind, _) = codomain_is_coind env deftype in
+  let vlra = lookup_subterms env mind in
+  check_rec_call env false 1 (dest_subterms vlra) def
+
+(* The  function which checks that the whole block of definitions 
+   satisfies the guarded condition *)
+
+let check_cofix env (bodynum,(names,types,bodies as recdef)) = 
+  let nbfix = Array.length bodies in 
+  for i = 0 to nbfix-1 do
+    let fixenv = push_rec_types recdef env in
+    try check_one_cofix fixenv nbfix bodies.(i) types.(i)
+    with CoFixGuardError (errenv,err) -> 
+      error_ill_formed_rec_body errenv err names i
+  done
diff --git a/checker/inductive.mli b/checker/inductive.mli
new file mode 100644
index 000000000..8e6d4ffb9
--- /dev/null
+++ b/checker/inductive.mli
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: inductive.mli 9420 2006-12-08 15:34:09Z barras $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Environ
+(*i*)
+
+(*s Extracting an inductive type from a construction *)
+
+val find_rectype : env -> constr -> 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 -> mind_specif
+
+val type_of_inductive : env -> mind_specif -> constr
+
+(* Return type as quoted by the user *)
+val type_of_constructor : constructor -> mind_specif -> constr
+
+val arities_of_specif : mutual_inductive -> mind_specif -> constr array
+
+(* [type_case_branches env (I,args) (p:A) c] computes useful types
+   about the following Cases expression:
+      <p>Cases (c :: (I args)) of b1..bn end
+   It computes the type of every branch (pattern variables are
+   introduced by products) and the type for the whole expression.
+ *)
+val type_case_branches :
+  env -> inductive * constr list -> constr * constr -> constr
+    -> constr array * constr
+
+(* Check a [case_info] actually correspond to a Case expression on the
+   given inductive type. *)
+val check_case_info : env -> inductive -> case_info -> unit
+
+(*s Guard conditions for fix and cofix-points. *)
+val check_fix : env -> fixpoint -> unit
+val check_cofix : env -> cofixpoint -> unit
+
+(*s Support for sort-polymorphic inductive types *)
+
+val type_of_inductive_knowing_parameters :
+  env -> one_inductive_body -> constr array -> constr
+
+val max_inductive_sort : sorts array -> Univ.universe
+
+val instantiate_universes : env -> rel_context ->
+    polymorphic_arity -> constr array -> rel_context * sorts
+
+(***************************************************************)
+(* Debug *)
+
+type size = Large | Strict
+type subterm_spec =
+    Subterm of (size * wf_paths)
+  | Dead_code
+  | Not_subterm
+type guard_env =
+  { env     : env;
+    (* dB of last fixpoint *)
+    rel_min : int;
+    (* inductive of recarg of each fixpoint *)
+    inds    : inductive array;
+    (* the recarg information of inductive family *)
+    recvec  : wf_paths array;
+    (* dB of variables denoting subterms *)
+    genv    : subterm_spec list;
+  }
+
+val subterm_specif : guard_env -> constr -> subterm_spec
+val case_branches_specif : guard_env -> subterm_spec -> inductive ->
+  constr array -> (guard_env * constr) array
diff --git a/checker/main.ml b/checker/main.ml
new file mode 100644
index 000000000..83b4ddd2d
--- /dev/null
+++ b/checker/main.ml
@@ -0,0 +1,2 @@
+
+let _ = Checker.start ()
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
new file mode 100644
index 000000000..18f190dff
--- /dev/null
+++ b/checker/mod_checking.ml
@@ -0,0 +1,388 @@
+
+open Pp
+open Util
+open Names
+open Term
+open Inductive
+open Reduction
+open Typeops
+open Indtypes
+open Modops
+open Subtyping
+open Declarations
+open Environ
+
+(************************************************************************)
+(* Checking constants *)
+
+let refresh_arity ar =
+  let ctxt, hd = decompose_prod_assum ar in
+  match hd with
+      Sort (Type u) when not (Univ.is_univ_variable u) ->
+        let u' = Univ.fresh_local_univ() in
+        mkArity (ctxt,Type u'),
+        Univ.enforce_geq u' u Univ.Constraint.empty
+    | _ -> ar, Univ.Constraint.empty
+
+let check_constant_declaration env kn cb =
+  Flags.if_verbose msgnl (str "  checking cst: " ++ prcon kn);
+  let env = add_constraints cb.const_constraints env in
+  let env' = check_named_ctxt env cb.const_hyps in
+  (match cb.const_type with
+      NonPolymorphicType ty ->
+        let ty, cu = refresh_arity ty in
+        let envty = add_constraints cu env' in 
+        let _ = infer_type envty ty in
+        (match cb.const_body with
+          | Some bd ->
+              let j = infer env' (force_constr bd) in
+              conv_leq envty j ty
+          | None -> ())
+    | _ -> failwith "polymorphic constants not supported");
+  add_constant kn cb env
+
+(************************************************************************)
+(* Checking modules *)
+
+
+let rec add_struct_expr_constraints env = function
+  | SEBident _ -> env
+
+  | SEBfunctor (_,mtb,meb) -> 
+      add_struct_expr_constraints 
+	(add_modtype_constraints env mtb) meb
+
+  | SEBstruct (_,structure_body) ->
+      List.fold_left 
+        (fun env (l,item) -> add_struct_elem_constraints env item)
+        env
+        structure_body
+
+  | SEBapply (meb1,meb2,cst) ->
+(*  let g = Univ.merge_constraints cst Univ.initial_universes in
+msgnl(str"ADDING FUNCTOR APPLICATION CONSTRAINTS:"++fnl()++
+      Univ.pr_universes g++str"============="++fnl());      
+*)
+      Environ.add_constraints cst 
+        (add_struct_expr_constraints 
+	  (add_struct_expr_constraints env meb1) 
+	  meb2)
+  | SEBwith(meb,With_definition_body(_,cb))->
+      Environ.add_constraints cb.const_constraints
+	(add_struct_expr_constraints env meb)
+  | SEBwith(meb,With_module_body(_,_,cst))->
+      Environ.add_constraints cst
+	(add_struct_expr_constraints env meb)	
+		
+and add_struct_elem_constraints env = function 
+  | SFBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SFBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SFBmodule mb -> add_module_constraints env mb
+  | SFBalias (mp,Some cst) -> Environ.add_constraints cst env
+  | SFBalias (mp,None) -> env
+  | SFBmodtype mtb -> add_modtype_constraints env mtb
+
+and add_module_constraints env mb = 
+  let env = match mb.mod_expr with
+    | None -> env
+    | Some meb -> add_struct_expr_constraints env meb
+  in
+  let env = match mb.mod_type with
+    | None -> env
+    | Some mtb -> 
+	add_struct_expr_constraints env mtb
+  in
+    Environ.add_constraints mb.mod_constraints env
+
+and add_modtype_constraints env mtb = 
+  add_struct_expr_constraints env mtb.typ_expr
+
+exception Not_path
+
+let path_of_mexpr = function
+  | SEBident mp -> mp
+  | _ -> raise Not_path
+
+let rec list_split_assoc k rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' -> rev_before,b,after
+  | h::tail -> list_split_assoc k (h::rev_before) tail
+
+let rec list_fold_map2 f e = function 
+  |  []  -> (e,[],[])
+  |  h::t -> 
+       let e',h1',h2' = f e h in
+       let e'',t1',t2' = list_fold_map2 f e' t in
+	 e'',h1'::t1',h2'::t2'
+
+
+let check_alias s1 s2 =
+  if s1 <> s2 then failwith "Incorrect alias"
+
+let check_definition_sub env cb1 cb2 =
+  let check_type env t1 t2 = 
+
+    (* If the type of a constant is generated, it may mention
+       non-variable algebraic universes that the general conversion
+       algorithm is not ready to handle. Anyway, generated types of
+       constants are functions of the body of the constant. If the
+       bodies are the same in environments that are subtypes one of
+       the other, the types are subtypes too (i.e. if Gamma <= Gamma',
+       Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
+       Hence they don't have to be checked again *)
+
+    let t1,t2 = 
+      if isArity t2 then
+        let (ctx2,s2) = destArity t2 in
+        match s2 with
+        | Type v when not (Univ.is_univ_variable v) ->
+          (* The type in the interface is inferred and is made of algebraic
+             universes *)
+          begin try
+            let (ctx1,s1) = dest_arity env t1 in
+            match s1 with
+            | Type u when not (Univ.is_univ_variable u) ->
+              (* Both types are inferred, no need to recheck them. We
+                 cheat and collapse the types to Prop *)
+                mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
+            | Prop _ ->
+              (* The type in the interface is inferred, it may be the case
+                 that the type in the implementation is smaller because
+                 the body is more reduced. We safely collapse the upper
+                 type to Prop *)
+                mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
+            | Type _ ->
+              (* The type in the interface is inferred and the type in the
+                 implementation is not inferred or is inferred but from a
+                 more reduced body so that it is just a variable. Since
+                 constraints of the form "univ <= max(...)" are not
+                 expressible in the system of algebraic universes: we fail
+                 (the user has to use an explicit type in the interface *)
+                raise Reduction.NotConvertible
+          with UserError _ (* "not an arity" *) ->
+            raise Reduction.NotConvertible end
+        | _ -> t1,t2
+      else
+        (t1,t2) in
+    Reduction.conv_leq env t1 t2
+  in
+  assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+  (*Start by checking types*)
+  let typ1 = Typeops.type_of_constant_type env cb1.const_type in
+  let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+  check_type env typ1 typ2;
+  (match cb2 with
+    | {const_body=Some lc2;const_opaque=false} ->
+	let c2 = force_constr lc2 in
+	let c1 = match cb1.const_body with
+	  | Some lc1 -> force_constr lc1
+	  | None -> assert false in
+	Reduction.conv env c1 c2
+    | _ -> ())
+
+let rec check_with env mtb with_decl = 
+  match with_decl with
+    | With_definition_body _ -> 
+	check_with_aux_def env mtb with_decl;
+	empty_subst
+    | With_module_body _ -> 
+	check_with_aux_mod env mtb with_decl
+
+and check_with_aux_def env mtb with_decl = 
+  let msid,sig_b = match (eval_struct env mtb) with 
+    | SEBstruct(msid,sig_b) ->
+	msid,sig_b
+    | _ -> error_signature_expected mtb
+  in
+  let id,idl = match with_decl with 
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) ->
+                                           id,idl
+    | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let env' = Modops.add_signature (MPself msid) before env in
+	match with_decl with
+          | With_definition_body ([],_) -> assert false
+	  | With_definition_body ([id],c) -> 
+	      let cb = match spec with
+		  SFBconst cb -> cb
+		| _ -> error_not_a_constant l
+	      in 
+              check_definition_sub env' c cb
+	  | With_definition_body (_::_,_) ->
+	      let old = match spec with
+		  SFBmodule msb -> msb
+		| _ -> error_not_a_module l
+	      in
+		begin
+		  match old.mod_expr with
+                    | None ->
+			let new_with_decl = match with_decl with
+			    With_definition_body (_,c) ->
+                              With_definition_body (idl,c)
+			  | With_module_body (_,c,cst) ->
+                              With_module_body (idl,c,cst) in 
+			  check_with_aux_def env' (type_of_mb env old) new_with_decl
+                    | Some msb ->
+			error_a_generative_module_expected l
+		end
+	  | _ -> anomaly "Modtyping:incorrect use of with"
+    with
+	Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_with_incorrect l
+
+and check_with_aux_mod env mtb with_decl = 
+  let initmsid,msid,sig_b =
+    match eval_struct env mtb with 
+    | SEBstruct(msid,sig_b) ->
+        let msid'=(refresh_msid msid) in
+	msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b)
+    | _ -> error_signature_expected mtb in
+  let id,idl = match with_decl with 
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) ->
+        id,idl
+    | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let rec mp_rec = function
+	| [] -> MPself initmsid
+	| i::r -> MPdot(mp_rec r,label_of_id i)
+      in 
+      let env' = Modops.add_signature (MPself msid) before env in
+	match with_decl with
+          | With_module_body ([],_,_) -> assert false
+	  | With_module_body ([id], mp,_) ->
+	      let old,alias = match spec with
+		  SFBmodule msb -> Some msb,None
+		| SFBalias (mp',_) -> None,Some mp'
+		| _ -> error_not_a_module l
+	      in
+	      let mtb' = lookup_modtype mp env' in
+	      let _ =
+		match old,alias with
+		    Some msb,None -> ()
+		  | None,Some mp' ->
+		      check_modpath_equiv env' mp mp'
+		  | _,_ ->
+		      anomaly "Mod_typing:no implementation and no alias"
+	      in
+		join (map_mp (mp_rec [id]) mp) mtb'.typ_alias
+        | With_module_body (_::_,mp,_) -> 
+	    let old = match spec with
+		SFBmodule msb -> msb
+	      | _ -> error_not_a_module l
+	    in
+	      begin
+		match old.mod_expr with
+                    None ->
+                      let new_with_decl = match with_decl with
+			  With_definition_body (_,c) -> 
+			    With_definition_body (idl,c)
+			| With_module_body (_,c,cst) ->
+                            With_module_body (idl,c,cst) in
+		      let sub =
+			check_with_aux_mod env' 
+			  (type_of_mb env old) new_with_decl in
+		      join (map_mp (mp_rec idl) mp) sub
+                  | Some msb ->
+                      error_a_generative_module_expected l
+              end
+	| _ -> anomaly "Modtyping:incorrect use of with"
+    with
+	Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_with_incorrect l
+
+and check_module_type env mty =
+  if mty.typ_strength <> None then
+    failwith "strengthening of module types not supported";
+  let sub = check_modexpr env mty.typ_expr in
+  check_alias mty.typ_alias sub
+
+and check_module env mb =
+  let env' = add_module_constraints env mb in
+  let sub =
+    match mb.mod_expr, mb.mod_type with
+      | None, None -> 
+	  anomaly "Mod_typing.translate_module: empty type and expr in module entry"
+      | None, Some mtb -> check_modexpr env' mtb
+
+      | Some mexpr, _ -> 
+	  let sub1 = check_modexpr env' mexpr in
+	  (match mb.mod_type with
+	    | None ->  sub1
+	    | Some mte -> 
+		let sub2 = check_modexpr env' mte in
+                check_subtypes env
+		  {typ_expr = mexpr;
+		   typ_strength = None;
+		   typ_alias = sub1;}
+		  {typ_expr = mte;
+		   typ_strength = None;
+		   typ_alias = sub2;};
+		sub2) in
+  check_alias mb.mod_alias sub
+
+and check_structure_field env mp lab = function
+  | SFBconst cb ->
+      let c = make_con mp empty_dirpath lab in
+      check_constant_declaration env c cb
+  | SFBmind mib ->
+      let kn = make_kn mp empty_dirpath lab in
+      Indtypes.check_inductive env kn mib
+  | SFBmodule msb ->
+      let _ = check_module env msb in
+      Modops.add_module (MPdot(mp,lab)) msb
+        (add_module_constraints env msb)
+  | SFBalias(mp2,cst) ->
+      (* TODO: check mp.lab and mp2 have the same sig *)
+      (try
+        let _ = lookup_module mp2 env in
+        register_alias (MPdot(mp,lab)) mp2 env
+      with Not_found -> failwith "unkown aliased module")
+  | SFBmodtype mty ->
+      let kn = MPdot(mp, lab) in
+      check_module_type env mty;
+      add_modtype kn mty (add_modtype_constraints env mty)
+
+and check_modexpr env mse = match mse with
+  | SEBident mp ->
+      let mtb = lookup_modtype mp env in 
+      mtb.typ_alias
+  | SEBfunctor (arg_id, mtb, body) ->
+      check_module_type env mtb;
+      let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in
+      check_modexpr env' body
+  | SEBapply (f,m,cst) ->
+      let sub1 = check_modexpr env f in
+      let f'= eval_struct env f in
+      let farg_id, farg_b, fbody_b = destr_functor env f' in
+      let mtb = 
+	try
+	  lookup_modtype (path_of_mexpr m) env
+	with
+	  | Not_path -> error_application_to_not_path m
+	      (* place for nondep_supertype *) in
+      let sub2= check_modexpr env m in
+      let sub = join sub1 sub2 in
+      let sub = join_alias sub (map_mbid farg_id (path_of_mexpr m)) in
+      let sub =
+        update_subst_alias sub (map_mbid farg_id (path_of_mexpr m)) in
+      check_subtypes env mtb farg_b;
+      sub
+  | SEBwith(mte, with_decl) ->
+	let sub1 = check_modexpr env mte in
+	let sub2 = check_with env mte with_decl in
+	join sub1 sub2
+  | SEBstruct(msid,msb) ->
+      let mp = MPself msid in
+      let _ =
+        List.fold_left (fun env (lab,mb) ->
+          check_structure_field env mp lab mb) env msb in
+      empty_subst
+
diff --git a/checker/modops.ml b/checker/modops.ml
new file mode 100644
index 000000000..fc8636a0b
--- /dev/null
+++ b/checker/modops.ml
@@ -0,0 +1,507 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: modops.ml 9872 2007-05-30 16:01:18Z soubiran $ i*)
+
+(*i*)
+open Util
+open Pp
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+(*i*)
+
+let error_not_a_constant l = 
+  error ("\""^(string_of_label l)^"\" is not a constant")
+
+let error_not_a_functor _ = error "Application of not a functor"
+
+let error_incompatible_modtypes _ _ = error "Incompatible module types"
+
+let error_not_equal _ _ = error "Not equal modules"
+
+let error_not_match l _ =
+  error ("Signature components for label "^string_of_label l^" do not match")
+
+let error_no_such_label l = error ("No such label "^string_of_label l)
+
+let error_no_such_label_sub l l1 l2 =
+  let l1 = string_of_msid l1 in
+  let l2 = string_of_msid l2 in
+  error (l1^" is not a subtype of "^l2^".\nThe field "^
+         string_of_label l^" is missing (or invisible) in "^l1^".")
+
+let error_not_a_module_loc loc s = 
+  user_err_loc (loc,"",str ("\""^string_of_label s^"\" is not a module"))
+
+let error_not_a_module s = error_not_a_module_loc dummy_loc s
+
+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_signature_expected mtb =
+  error "Signature expected"
+
+let error_application_to_not_path _ = error "Application to not path"
+
+
+let module_body_of_type mtb = 
+  { mod_type = Some mtb.typ_expr;
+    mod_expr = None;
+    mod_constraints = Constraint.empty;
+    mod_alias = mtb.typ_alias;
+    mod_retroknowledge = []}
+
+let module_type_of_module mp mb =
+  {typ_expr = 
+      (match mb.mod_type with
+	| Some expr -> expr
+	| None -> (match mb.mod_expr with
+		     | Some expr -> expr
+		     | None -> 
+			 anomaly "Modops: empty expr and type"));
+   typ_alias = mb.mod_alias;
+   typ_strength = mp
+  }
+
+
+
+let rec list_split_assoc k rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' -> rev_before,b,after
+  | h::tail -> list_split_assoc k (h::rev_before) tail
+
+let path_of_seb = function
+  | SEBident mp -> mp
+  | _ -> anomaly "Modops: evaluation failed."
+
+
+let destr_functor env mtb =
+  match mtb with
+  | SEBfunctor (arg_id,arg_t,body_t) ->
+      	    (arg_id,arg_t,body_t)
+  | _ -> error_not_a_functor mtb
+
+
+let rec check_modpath_equiv env mp1 mp2 = 
+  if mp1=mp2 then () else
+  let mp1 = scrape_alias mp1 env in
+  let mp2 = scrape_alias mp2 env in
+    if mp1=mp2 then ()
+    else 
+      error_not_equal mp1 mp2
+
+
+
+let strengthen_const env mp l cb = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None -> 
+      let const = Const (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
+	}
+
+let strengthen_mind env mp l mib = match mib.mind_equiv with
+  | Some _ -> mib
+  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
+
+
+let rec eval_struct env = function 
+  | SEBident mp -> 
+      begin
+	let mtb =lookup_modtype mp env in
+	match mtb.typ_expr,mtb.typ_strength with
+	    mtb,None -> eval_struct env mtb
+	  | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb)
+      end
+  | SEBapply (seb1,seb2,_) -> 
+      let svb1 = eval_struct env seb1 in
+      let farg_id, farg_b, fbody_b = destr_functor env svb1 in
+      let mp = path_of_seb seb2 in
+      let mp = scrape_alias mp env in
+      let sub_alias = (lookup_modtype mp env).typ_alias in
+      let sub_alias = match eval_struct env (SEBident mp) with
+	  | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) sub_alias
+	  | _ -> sub_alias in
+      let sub_alias = update_subst_alias sub_alias 
+	(map_mbid farg_id mp) in
+	eval_struct env (subst_struct_expr 
+			   (join sub_alias (map_mbid farg_id mp)) fbody_b)
+  | SEBwith (mtb,(With_definition_body _ as wdb)) ->
+      merge_with env mtb wdb empty_subst
+  | SEBwith (mtb, (With_module_body (_,mp,_) as wdb)) ->
+      let alias_in_mp =
+	(lookup_modtype mp env).typ_alias in
+	merge_with env mtb wdb alias_in_mp
+(*  | SEBfunctor(mbid,mtb,body) -> 
+      let env = add_module (MPbound mbid) (module_body_of_type mtb) env in
+	SEBfunctor(mbid,mtb,eval_struct env body) *)
+  | mtb -> mtb
+      
+and type_of_mb env mb =
+  match mb.mod_type,mb.mod_expr with
+      None,Some b -> eval_struct env b
+    | Some t, _ -> eval_struct env t
+    | _,_ -> anomaly 
+	"Modops:  empty type and empty expr" 
+	  
+and merge_with env mtb with_decl alias= 
+  let msid,sig_b = match (eval_struct env mtb) with 
+    | SEBstruct(msid,sig_b) -> msid,sig_b
+    | _ -> error_signature_expected mtb
+  in
+  let id,idl = match with_decl with 
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) -> id,idl
+    | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let before = List.rev rev_before in
+      let rec mp_rec = function
+	| [] -> MPself msid
+	| i::r -> MPdot(mp_rec r,label_of_id i)
+      in 
+      let new_spec,subst = match with_decl with
+        | With_definition_body ([],_)
+        | With_module_body ([],_,_) -> assert false
+	| With_definition_body ([id],c) -> 
+	    SFBconst c,None
+	| With_module_body ([id], mp,cst) ->
+	    let mp' = scrape_alias mp env in
+	      SFBalias (mp,Some cst),
+	    Some(join (map_mp (mp_rec [id]) mp') alias)
+	| With_definition_body (_::_,_) 
+        | With_module_body (_::_,_,_) -> 
+	    let old = match spec with
+		SFBmodule msb -> msb
+	      | _ -> error_not_a_module l
+	    in
+            let new_with_decl,subst1 = 
+	      match with_decl with
+                  With_definition_body (_,c) -> With_definition_body (idl,c),None
+		| With_module_body (idc,mp,cst) -> 
+		    With_module_body (idl,mp,cst),
+		      Some(map_mp (mp_rec idc) mp) 
+	    in
+	    let subst = Option.fold_right join subst1 alias in
+            let modtype = 
+              merge_with env (type_of_mb env old) new_with_decl alias in
+            let msb =
+	      { mod_expr = None;
+		mod_type = Some modtype; 
+		mod_constraints = old.mod_constraints;
+		mod_alias = subst;
+		mod_retroknowledge = old.mod_retroknowledge}
+	    in
+	      (SFBmodule msb),Some subst
+      in
+	SEBstruct(msid,  before@(l,new_spec)::
+		    (Option.fold_right subst_structure subst after))
+    with
+	Not_found -> error_no_such_label l
+
+and add_signature mp sign env = 
+  let add_one env (l,elem) =
+    let kn = make_kn mp empty_dirpath l in
+    let con = make_con mp empty_dirpath l in
+      match elem with
+	| SFBconst cb -> Environ.add_constant con cb env
+	| SFBmind mib -> Environ.add_mind kn mib env
+	| SFBmodule mb -> 
+	    add_module (MPdot (mp,l)) mb env 
+	      (* adds components as well *)
+	| SFBalias (mp1,cst) -> 
+	    Environ.register_alias (MPdot(mp,l)) mp1 env
+	| SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) 
+	    mtb env
+  in
+    List.fold_left add_one env sign
+
+and add_module mp mb env = 
+  let env = Environ.shallow_add_module mp mb env in
+  let env =
+    Environ.add_modtype mp (module_type_of_module (Some mp) mb) env
+  in
+  let mod_typ = type_of_mb env mb in
+    match mod_typ with
+      | SEBstruct (msid,sign) -> 
+	  add_signature mp (subst_signature_msid msid mp sign) env
+      | SEBfunctor _ -> env
+      | _ -> anomaly "Modops:the evaluation of the structure failed "
+	  
+
+
+and  constants_of_specification env mp sign =
+ let aux (env,res) (l,elem) =
+  match elem with
+   | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
+   | SFBmind _ -> env,res
+   | SFBmodule mb ->
+       let new_env =  add_module (MPdot (mp,l)) mb env in 
+       new_env,(constants_of_modtype env (MPdot (mp,l))
+		   (type_of_mb env mb)) @ res
+   | SFBalias (mp1,cst) ->
+       let new_env =  register_alias (MPdot (mp,l)) mp1 env in 
+       new_env,(constants_of_modtype env (MPdot (mp,l))
+		   (eval_struct env (SEBident mp1))) @ res
+   | SFBmodtype mtb -> 
+       (* module type dans un module type. 
+	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
+	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
+	  mtb
+	  ex: 
+	  Module Type T1. 
+	  Module Type T2.
+	     ....
+    	    End T2.
+	  .....
+            Declare Module M : T2.
+         End T2 
+	  si on ne rajoute pas T2 dans l'environement de typage 
+	  on va exploser au moment du Declare Module
+       *)
+       let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in 
+       new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res
+ in
+ snd (List.fold_left aux (env,[]) sign)
+
+and constants_of_modtype env mp modtype =
+  match (eval_struct env modtype) with
+      SEBstruct (msid,sign) ->
+	constants_of_specification env mp
+	  (subst_signature_msid msid mp sign)
+    | SEBfunctor _ -> []
+    | _ -> anomaly "Modops:the evaluation of the structure failed "
+    
+and strengthen_mtb env mp mtb =
+  let mtb1 = eval_struct env mtb in 
+  match  mtb1 with
+  | SEBfunctor _ -> mtb1
+  | SEBstruct (msid,sign) -> 
+      SEBstruct (msid,strengthen_sig env msid sign mp)
+  | _ -> anomaly "Modops:the evaluation of the structure failed "
+
+and strengthen_mod env mp mb = 
+  let mod_typ = type_of_mb env mb in
+    { mod_expr = mb.mod_expr;
+      mod_type = Some (strengthen_mtb env mp mod_typ);
+      mod_constraints = mb.mod_constraints;
+      mod_alias = mb.mod_alias;
+      mod_retroknowledge = mb.mod_retroknowledge}
+      
+and strengthen_sig env msid sign mp = match sign with
+  | [] -> []
+  | (l,SFBconst cb) :: rest ->
+      let item' = l,SFBconst (strengthen_const env mp l cb) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SFBmind mib) :: rest ->
+      let item' = l,SFBmind (strengthen_mind env mp l mib) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SFBmodule mb) :: rest ->
+      let mp' = MPdot (mp,l) in
+	let item' = l,SFBmodule (strengthen_mod env mp' mb) in
+	let env' = add_module 
+	  (MPdot (MPself msid,l)) mb env in
+        let rest' = strengthen_sig env' msid rest mp in
+	item':: rest'
+  | ((l,SFBalias (mp1,cst)) as item) :: rest ->
+      let env' = register_alias (MPdot(MPself msid,l)) mp1 env in
+      let rest' = strengthen_sig env' msid rest mp in
+	item::rest'
+  | (l,SFBmodtype mty as item) :: rest -> 
+      let env' = add_modtype 
+		   (MPdot((MPself msid),l)) 
+		   mty
+		   env
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item::rest'
+
+    
+let strengthen env mtb mp = strengthen_mtb env mp mtb
+
+
+(*
+
+
+let rec scrape_modtype env = function
+  | MTBident kn ->
+      let mtb =
+        try lookup_modtype kn env
+        with Not_found ->
+          anomalylabstrm "scrape_modtype"
+            (str"scrape_modtype: cannot find "(*++pr_kn kn*)) in
+      scrape_modtype env mtb
+  | mtb -> mtb
+
+
+(* the constraints are not important here *)
+let module_spec_of_body mb = 
+  { msb_modtype = mb.mod_type; 
+    msb_equiv = mb.mod_equiv; 
+    msb_constraints = Constraint.empty}
+
+
+
+let destr_functor = function
+  | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
+  | mtb -> error_not_a_functor mtb
+
+let rec check_modpath_equiv env mp1 mp2 = 
+  if mp1=mp2 then () else
+  let mb1 = lookup_module mp1 env in
+    match mb1.mod_equiv with
+      | None ->
+	  let mb2 = lookup_module mp2 env in
+	    (match mb2.mod_equiv with
+	      | None -> error_not_equal mp1 mp2
+	      | Some mp2' -> check_modpath_equiv env mp2' mp1)
+      | Some mp1' -> check_modpath_equiv env mp2 mp1'
+
+
+(* 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 -> add_constant con cb env
+	| SPBmind mib -> add_mind kn mib env
+	| SPBmodule mb -> 
+	    add_module (MPdot (mp,l)) (module_body_of_spec mb) env 
+	    (* adds components as well *)
+	| SPBmodtype mtb -> add_modtype kn mtb env
+  in
+    List.fold_left add_one env sign
+
+
+and add_module mp mb env = 
+  let env = shallow_add_module mp mb env in
+    match scrape_modtype env mb.mod_type with
+      | MTBident _ -> anomaly "scrape_modtype does not work!"
+      | MTBsig (msid,sign) -> 
+	  add_signature mp (subst_signature_msid msid mp sign) env
+      | MTBfunsig _ -> env
+
+
+let rec constants_of_specification env mp sign =
+ let aux (env,res) (l,elem) =
+  match elem with
+   | SPBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
+   | SPBmind _ -> env,res
+   | SPBmodule mb ->
+       let new_env =  add_module (MPdot (mp,l)) (module_body_of_spec mb) env in 
+       new_env,(constants_of_modtype env (MPdot (mp,l))
+		  (module_body_of_spec mb).mod_type) @ res
+   | SPBmodtype mtb -> 
+       (* module type dans un module type. 
+	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
+	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
+	  mtb
+	  ex: 
+	  Module Type T1. 
+	  Module Type T2.
+	     ....
+    	    End T2.
+	  .....
+            Declare Module M : T2.
+         End T2 
+	  si on ne rajoute pas T2 dans l'environement de typage 
+	  on va exploser au moment du Declare Module
+       *)
+       let new_env = add_modtype (make_kn mp empty_dirpath l) mtb env in 
+       new_env, constants_of_modtype env (MPdot(mp,l)) mtb @ res
+ in
+ snd (List.fold_left aux (env,[]) sign)
+
+and constants_of_modtype env mp modtype =
+ match scrape_modtype env modtype with
+    MTBident _ -> anomaly "scrape_modtype does not work!"
+  | MTBsig (msid,sign) ->
+     constants_of_specification env mp
+      (subst_signature_msid msid mp sign)
+  | MTBfunsig _ -> []
+
+
+let strengthen_const env mp l cb = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None -> 
+      let const = Const (make_con mp empty_dirpath l) in 
+      let const_subs = Some (from_val const) in
+	{cb with 
+      	   const_body = const_subs;
+	   const_opaque = false(*;
+           const_body_code = Cemitcodes.from_val
+             (compile_constant_body env const_subs false false)*)
+	}
+
+let strengthen_mind env mp l mib = match mib.mind_equiv with
+  | Some _ -> mib
+  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
+    
+let rec strengthen_mtb env mp mtb = match scrape_modtype env mtb with
+  | MTBident _ -> anomaly "scrape_modtype does not work!"
+  | MTBfunsig _ -> mtb
+  | MTBsig (msid,sign) -> MTBsig (msid,strengthen_sig env msid sign mp)
+
+and strengthen_mod env mp msb = 
+  { msb_modtype = strengthen_mtb env mp msb.msb_modtype;
+    msb_equiv = begin match msb.msb_equiv with
+      | Some _ -> msb.msb_equiv
+      | None -> Some mp 
+    end ;
+    msb_constraints = msb.msb_constraints; }
+
+and strengthen_sig env msid sign mp = match sign with
+  | [] -> []
+  | (l,SPBconst cb) :: rest ->
+      let item' = l,SPBconst (strengthen_const env mp l cb) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmind mib) :: rest ->
+      let item' = l,SPBmind (strengthen_mind env mp l mib) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmodule mb) :: rest ->
+      let mp' = MPdot (mp,l) in
+      let item' = l,SPBmodule (strengthen_mod env mp' mb) in
+      let env' = add_module 
+		   (MPdot (MPself msid,l)) 
+		   (module_body_of_spec mb) 
+		   env
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item'::rest'
+  | (l,SPBmodtype mty as item) :: rest -> 
+      let env' = add_modtype 
+		   (make_kn (MPself msid) empty_dirpath l) 
+		   mty
+		   env
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item::rest'
+
+let strengthen env mtb mp = strengthen_mtb env mp mtb
+*)
diff --git a/checker/modops.mli b/checker/modops.mli
new file mode 100644
index 000000000..10b231f44
--- /dev/null
+++ b/checker/modops.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: modops.mli 9821 2007-05-11 17:00:58Z aspiwack $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+(*i*)
+
+(* Various operations on modules and module types *)
+
+(* make the environment entry out of type *)
+val module_body_of_type : module_type_body -> module_body
+
+val module_type_of_module : module_path option -> module_body -> 
+  module_type_body 
+
+val destr_functor : 
+  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
+
+(* Evaluation functions *)
+val eval_struct : env -> struct_expr_body -> struct_expr_body
+
+val type_of_mb : env -> module_body -> struct_expr_body
+
+(* [add_signature mp sign env] assumes that the substitution [msid]
+   $\mapsto$ [mp] has already been performed (or is not necessary, like
+   when [mp = MPself msid]) *)
+val add_signature : module_path -> structure_body -> env -> env
+
+(* adds a module and its components, but not the constraints *)
+val add_module : module_path -> module_body ->  env -> env
+
+val check_modpath_equiv : env -> module_path -> module_path -> unit
+
+val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body
+
+val error_incompatible_modtypes : 
+  module_type_body -> module_type_body -> 'a
+
+val error_not_match : label -> structure_field_body -> 'a
+
+val error_with_incorrect : label -> 'a
+
+val error_no_such_label : label -> 'a
+
+val error_no_such_label_sub :
+  label -> mod_self_id -> mod_self_id -> 'a
+
+val error_signature_expected : struct_expr_body -> 'a
+
+val error_not_a_constant : label -> 'a
+
+val error_not_a_module : label -> 'a 
+
+val error_a_generative_module_expected : label -> 'a
+
+val error_application_to_not_path : struct_expr_body -> 'a
diff --git a/checker/reduction.ml b/checker/reduction.ml
new file mode 100644
index 000000000..503a1b29a
--- /dev/null
+++ b/checker/reduction.ml
@@ -0,0 +1,400 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: reduction.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
+
+open Util
+open Names
+open Term
+open Univ
+open Closure
+open Esubst
+open Environ
+
+let rec is_empty_stack = function
+    [] -> true
+  | Zupdate _::s -> is_empty_stack s
+  | Zshift _::s -> is_empty_stack s
+  | _ -> false
+
+(* Compute the lift to be performed on a term placed in a given stack *)
+let el_stack el stk =
+  let n =
+    List.fold_left
+      (fun i z ->
+        match z with
+            Zshift n -> i+n
+          | _ -> i)
+      0
+      stk in
+  el_shft n el
+
+let compare_stack_shape stk1 stk2 =
+  let rec compare_rec bal stk1 stk2 =
+  match (stk1,stk2) with
+      ([],[]) -> bal=0
+    | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2
+    | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
+    | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
+    | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
+    | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) ->
+        bal=0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
+    | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
+        bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
+    | (_,_) -> false in
+  compare_rec 0 stk1 stk2
+
+type lft_constr_stack_elt =
+    Zlapp of (lift * fconstr) array
+  | Zlfix of (lift * fconstr) * lft_constr_stack
+  | Zlcase of case_info * lift * fconstr * fconstr array
+and lft_constr_stack = lft_constr_stack_elt list
+
+let rec zlapp v = function
+    Zlapp v2 :: s -> zlapp (Array.append v v2) s
+  | s -> Zlapp v :: s
+
+let pure_stack lfts stk =
+  let rec pure_rec lfts stk =
+    match stk with
+        [] -> (lfts,[])
+      | zi::s ->
+          (match (zi,pure_rec lfts s) with
+              (Zupdate _,lpstk)  -> lpstk
+            | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
+            | (Zapp a, (l,pstk)) ->
+                (l,zlapp (Array.map (fun t -> (l,t)) a) pstk)
+            | (Zfix(fx,a),(l,pstk)) ->
+                let (lfx,pa) = pure_rec l a in
+                (l, Zlfix((lfx,fx),pa)::pstk)
+            | (Zcase(ci,p,br),(l,pstk)) ->
+                (l,Zlcase(ci,l,p,br)::pstk)) in
+  snd (pure_rec lfts stk)
+
+(****************************************************************************)
+(*                   Reduction Functions                                    *)
+(****************************************************************************)
+
+let whd_betaiotazeta env x =
+  match x with
+    | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> x
+    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
+
+let whd_betadeltaiota env t = 
+  match t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
+
+let whd_betadeltaiota_nolet env t = 
+  match t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t)
+
+(* Beta *)
+
+let beta_appvect c v =
+  let rec stacklam env t stack =
+    match t, stack with
+        Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl
+      | _ -> applist (substl env t, stack) in
+  stacklam [] c (Array.to_list v)
+
+(********************************************************************)
+(*                         Conversion                               *)
+(********************************************************************)
+
+(* Conversion utility functions *)
+type 'a conversion_function = env -> 'a -> 'a -> unit
+
+exception NotConvertible
+exception NotConvertibleVect of int
+
+let compare_stacks f fmind lft1 stk1 lft2 stk2 =
+  let rec cmp_rec pstk1 pstk2 =
+    match (pstk1,pstk2) with
+      | (z1::s1, z2::s2) ->
+          cmp_rec s1 s2;
+          (match (z1,z2) with
+            | (Zlapp a1,Zlapp a2) -> array_iter2 f a1 a2
+            | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
+                f fx1 fx2; cmp_rec a1 a2
+            | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) ->
+                if not (fmind ci1.ci_ind ci2.ci_ind) then
+		  raise NotConvertible;
+		f (l1,p1) (l2,p2);
+                array_iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2
+            | _ -> assert false)
+      | _ -> () in
+  if compare_stack_shape stk1 stk2 then
+    cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2)
+  else raise NotConvertible
+
+(* Convertibility of sorts *)
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+let sort_cmp univ pb s0 s1 =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible
+    | (Prop c1, Type u)  ->
+        (match pb with
+            CUMUL -> ()
+          | _ -> raise NotConvertible)
+    | (Type u1, Type u2) ->
+        if not
+	  (match pb with
+            | CONV -> check_eq univ u1 u2
+	    | CUMUL -> check_geq univ u2 u1)
+        then raise NotConvertible
+    | (_, _) -> raise NotConvertible
+
+
+(* Conversion between  [lft1]term1 and [lft2]term2 *)
+let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = 
+  Util.check_for_interrupt ();
+  eqappr univ cv_pb infos
+    (lft1, whd_stack infos term1 [])
+    (lft2, whd_stack infos term2 [])
+
+(* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
+and eqappr univ cv_pb infos appr1 appr2 =
+  let (lft1,(hd1,v1)) = appr1 in
+  let (lft2,(hd2,v2)) = appr2 in
+  let el1 = el_stack lft1 v1 in
+  let el2 = el_stack lft2 v2 in
+  match (fterm_of hd1, fterm_of hd2) with
+    (* case of leaves *)
+    | (FAtom a1, FAtom a2) ->
+	(match a1, a2 with
+	   | (Sort s1, Sort s2) -> 
+	       assert (is_empty_stack v1 && is_empty_stack v2);
+	       sort_cmp univ cv_pb s1 s2
+	   | (Meta n, Meta m) ->
+               if n=m
+	       then convert_stacks univ infos lft1 lft2 v1 v2
+               else raise NotConvertible
+	   | _ -> raise NotConvertible)
+    | (FEvar (ev1,args1), FEvar (ev2,args2)) ->
+        if ev1=ev2 then
+          (convert_stacks univ infos lft1 lft2 v1 v2;
+           convert_vect univ infos el1 el2 args1 args2)
+        else raise NotConvertible
+
+    (* 2 index known to be bound to no constant *)
+    | (FRel n, FRel m) ->
+        if reloc_rel n el1 = reloc_rel m el2
+        then convert_stacks univ infos lft1 lft2 v1 v2
+        else raise NotConvertible
+
+    (* 2 constants, 2 local defined vars or 2 defined rels *)
+    | (FFlex fl1, FFlex fl2) ->
+	(try (* try first intensional equality *)
+	  if fl1 = fl2
+          then convert_stacks univ infos lft1 lft2 v1 v2
+          else raise NotConvertible
+        with NotConvertible ->
+          (* else the oracle tells which constant is to be expanded *)
+          let (app1,app2) =
+	      match unfold_reference infos fl2 with
+                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                | None ->
+                    (match unfold_reference infos fl1 with
+                    | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+		    | None -> raise NotConvertible) in
+          eqappr univ cv_pb infos app1 app2)
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 -> 
+	       eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 -> 
+	       eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2)
+           | None -> raise NotConvertible)
+	
+    (* other constructors *)
+    | (FLambda _, FLambda _) ->
+        let (_,ty1,bd1) = destFLambda mk_clos hd1 in
+        let (_,ty2,bd2) = destFLambda mk_clos hd2 in
+        ccnv univ CONV infos el1 el2 ty1 ty2;
+        ccnv univ CONV infos (el_lift el1) (el_lift el2) bd1 bd2
+
+    | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
+        assert (is_empty_stack v1 && is_empty_stack v2);
+	(* Luo's system *)
+        ccnv univ CONV infos el1 el2 c1 c'1;
+        ccnv univ cv_pb infos (el_lift el1) (el_lift el2) c2 c'2
+
+    (* Inductive types:  MutInd MutConstruct Fix Cofix *)
+
+     | (FInd ind1, FInd ind2) ->
+         if mind_equiv_infos infos ind1 ind2
+	 then
+           convert_stacks univ infos lft1 lft2 v1 v2
+         else raise NotConvertible
+
+     | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
+	 if j1 = j2 && mind_equiv_infos infos ind1 ind2
+	 then
+           convert_stacks univ infos lft1 lft2 v1 v2
+         else raise NotConvertible
+
+     | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
+	 if op1 = op2
+	 then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+           convert_vect univ infos el1 el2 fty1 fty2;
+           convert_vect univ infos 
+	     (el_liftn n el1) (el_liftn n el2) fcl1 fcl2;
+           convert_stacks univ infos lft1 lft2 v1 v2
+         else raise NotConvertible
+
+     | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
+         if op1 = op2
+         then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+           convert_vect univ infos el1 el2 fty1 fty2;
+	   convert_vect univ infos
+	     (el_liftn n el1) (el_liftn n el2) fcl1 fcl2;
+           convert_stacks univ infos lft1 lft2 v1 v2
+         else raise NotConvertible
+
+    (* Can happen because whd_stack on one arg may have side-effects
+       on the other arg and coulb be no more in hnf... *)
+    | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_)
+      | (FCLOS _, _) | (FLIFT _, _)) ->
+        eqappr univ cv_pb infos (lft1, whd_stack infos hd1 v1) appr2
+
+    | ( (_, FLetIn _) | (_,FCases _) | (_,FApp _)
+      | (_,FCLOS _) | (_,FLIFT _)) ->
+        eqappr univ cv_pb infos (lft1, whd_stack infos hd1 v1) appr2
+
+    (* Should not happen because whd_stack unlocks references *)
+    | ((FLOCKED,_) | (_,FLOCKED)) -> assert false
+
+     | _ -> raise NotConvertible
+
+and convert_stacks univ infos lft1 lft2 stk1 stk2 =
+  compare_stacks
+    (fun (l1,t1) (l2,t2) -> ccnv univ CONV infos l1 l2 t1 t2)
+    (mind_equiv_infos infos)
+    lft1 stk1 lft2 stk2
+
+and convert_vect univ infos lft1 lft2 v1 v2 =
+  array_iter2 (fun t1 t2 -> ccnv univ CONV infos lft1 lft2 t1 t2) v1 v2
+
+let clos_fconv cv_pb env t1 t2 =
+  let infos = create_clos_infos betaiotazeta env in
+  let univ = universes env in
+  ccnv univ cv_pb infos ELID ELID (inject t1) (inject t2)
+
+let fconv cv_pb env t1 t2 =
+  if eq_constr t1 t2 then ()
+  else clos_fconv cv_pb env t1 t2
+
+let conv_cmp = fconv
+let conv = fconv CONV
+let conv_leq = fconv CUMUL
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i _ t1 t2 ->
+      (try conv_leq env t1 t2 
+      with (NotConvertible|Invalid_argument _) ->
+        raise (NotConvertibleVect i));
+      ())
+    ()
+    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
+  
+(********************************************************************)
+(*             Special-Purpose Reduction                            *)
+(********************************************************************)
+
+(* pseudo-reduction rule:
+ * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
+ * with an HNF on the first argument to produce a product.
+ * if this does not work, then we use the string S as part of our
+ * error message. *)
+
+let hnf_prod_app env t n =
+  match whd_betadeltaiota env t with
+    | Prod (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_prod_app: Need a product"
+
+let hnf_prod_applist env t nl = 
+  List.fold_left (hnf_prod_app env) t nl
+
+(* Dealing with arities *)
+
+let dest_prod env = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env c in
+    match t with
+      | Prod (n,a,c0) ->
+          let d = (n,None,a) in
+	  decrec (push_rel d env) (d::m) c0
+      | _ -> m,t
+  in 
+  decrec env empty_rel_context
+
+(* The same but preserving lets *)
+let dest_prod_assum env = 
+  let rec prodec_rec env l ty =
+    let rty = whd_betadeltaiota_nolet env ty in
+    match rty with
+    | Prod (x,t,c)  ->
+        let d = (x,None,t) in
+	prodec_rec (push_rel d env) (d::l) c
+    | LetIn (x,b,t,c) ->
+        let d = (x,Some b,t) in
+	prodec_rec (push_rel d env) (d::l) c
+    | Cast (c,_,_)    -> prodec_rec env l c
+    | _               -> l,rty
+  in
+  prodec_rec env empty_rel_context
+
+let dest_arity env c =
+  let l, c = dest_prod_assum env c in
+  match c with
+    | Sort s -> l,s
+    | _ -> error "not an arity"
+
+let is_arity env c =
+  try
+    let _ = dest_arity env c in
+    true
+  with UserError _ -> false
+
diff --git a/checker/reduction.mli b/checker/reduction.mli
new file mode 100644
index 000000000..eb50ae32e
--- /dev/null
+++ b/checker/reduction.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: reduction.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
+
+(*i*)
+open Term
+open Environ
+(*i*)
+
+(************************************************************************)
+(*s Reduction functions *)
+
+val whd_betaiotazeta        : env -> constr -> constr
+val whd_betadeltaiota       : env -> constr -> constr
+val whd_betadeltaiota_nolet : env -> constr -> constr
+
+(************************************************************************)
+(*s conversion functions *)
+
+exception NotConvertible
+exception NotConvertibleVect of int
+type 'a conversion_function = env -> 'a -> 'a -> unit
+
+type conv_pb = CONV | CUMUL
+
+val conv           : constr conversion_function
+val conv_leq       : constr conversion_function
+val conv_leq_vecti : constr array conversion_function
+
+val vm_conv : conv_pb -> constr conversion_function
+
+(************************************************************************)
+
+(* Builds an application node, reducing beta redexes it may produce. *) 
+val beta_appvect : constr -> constr array -> constr
+
+(* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
+val hnf_prod_applist : env -> constr -> constr list -> constr
+
+
+(************************************************************************)
+(*s Recognizing products and arities modulo reduction *)
+
+val dest_prod       : env -> constr -> rel_context * constr
+val dest_prod_assum : env -> constr -> rel_context * constr
+
+val dest_arity : env -> constr -> arity
+val is_arity   : env -> constr -> bool
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
new file mode 100644
index 000000000..c6388499a
--- /dev/null
+++ b/checker/safe_typing.ml
@@ -0,0 +1,248 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: safe_typing.ml 10275 2007-10-30 11:01:24Z barras $ *)
+
+open Pp
+open Util
+open Names
+open Declarations
+open Environ
+open Mod_checking
+
+(*
+let type_modpath env mp = 
+  strengthen env (lookup_module mp env).mod_type mp
+
+let rec check_spec_body env mp lab = function
+  | SPBconst cb ->
+      let kn = mp, empty_dirpath, lab in
+      check_constant_declaration env kn cb
+  | SPBmind mib ->
+      let kn = mp, empty_dirpath, lab in
+      Indtypes.check_inductive env kn mib
+  | SPBmodule msb ->
+      check_mod_spec env msb;
+      Modops.add_module (MPdot(mp,lab)) (module_body_of_type msb.msb_modtype)
+        (add_modtype_constraints env msb.msb_modtype)
+  | SPBmodtype mty ->
+      let kn = mp, empty_dirpath, lab in
+      check_modtype env mty;
+      add_modtype kn mty (add_modtype_constraints env mty)
+
+and check_mod_spec env msb =
+  let env' = add_constraints msb.msb_constraints env in
+  check_modtype env' msb.msb_modtype;
+
+(*  Subtyping.check_equal env' msb.msb_modtype (MTBident *)
+  (* TODO: check equiv *)
+  env'
+
+(* !!!: modtype needs mp (the name it will be given) because
+   submodule should be added without reference to self *)
+and check_modtype env = function
+  | MTBident kn ->
+      (try let _ = lookup_modtype kn env in ()
+      with Not_found -> failwith ("unbound module type "(*^string_of_kn kn*)))
+  | MTBfunsig (mbid,marg,mbody) ->
+      check_modtype env marg;
+      let env' = 
+	add_module (MPbound mbid) (module_body_of_type marg)
+          (add_modtype_constraints env marg) in
+      check_modtype env' mbody
+  | MTBsig (msid,sign) ->
+      let _ =
+        List.fold_left (fun env (lab,mb) ->
+          check_spec_body env (MPself msid) lab mb) env sign in
+      ()
+
+
+let elem_spec_of_body (lab,e) =
+  lab,
+  match e with
+      SEBconst cb -> SPBconst cb
+    | SEBmind mind -> SPBmind mind
+    | SEBmodule msb -> SPBmodule (module_spec_of_body msb)
+    | SEBmodtype mtb -> SPBmodtype mtb
+
+let rec check_module env mb =
+  let env' = add_module_constraints env mb in
+  (* mod_type *)
+  check_modtype env' mb.mod_type;
+  (* mod_expr *)
+  let msig =
+    match mb.mod_expr with
+        Some mex ->
+          let msig = infer_mod_expr env' mex in
+          Subtyping.check_subtypes env' msig mb.mod_type;
+          msig
+      | None -> mb.mod_type in
+  (* mod_user_type *)
+  (match mb.mod_user_type with
+      Some usig -> Subtyping.check_subtypes env' msig usig
+    | None -> ());
+  (* mod_equiv *)
+  (match mb.mod_equiv with
+      Some mid ->
+        if mb.mod_expr <> Some(MEBident mid) then
+          failwith "incorrect module alias"
+    | None -> ());
+
+and infer_mod_expr env = function
+    MEBident mp -> type_modpath env mp
+  | MEBstruct(msid,msb) ->
+      let mp = MPself msid in
+      let _ =
+        List.fold_left (fun env (lab,mb) ->
+          struct_elem_body env mp lab mb) env msb in
+      MTBsig(msid,List.map elem_spec_of_body msb)
+  | MEBfunctor (arg_id, arg, body) ->
+      check_modtype env arg;
+      let env' = add_module (MPbound arg_id) (module_body_of_type arg) env in
+      let body_ty = infer_mod_expr env' body in
+      MTBfunsig (arg_id, arg, body_ty)
+  | MEBapply (fexpr,MEBident mp,_) ->
+      let ftb = infer_mod_expr env fexpr in
+      let ftb = scrape_modtype env ftb in
+      let farg_id, farg_b, fbody_b = destr_functor ftb in
+      let mtb = type_modpath env mp in
+      Subtyping.check_subtypes env mtb farg_b;
+      subst_modtype (map_mbid farg_id mp) fbody_b
+  | MEBapply _ ->
+      failwith "functor argument must be a module variable"
+
+and struct_elem_body env mp lab = function
+  | SEBconst cb ->
+      let kn = mp, empty_dirpath, lab in
+      check_constant_declaration env kn cb
+  | SEBmind mib ->
+      let kn = mp, empty_dirpath, lab in
+      Indtypes.check_inductive env kn mib
+  | SEBmodule msb ->
+      check_module env msb;
+(*msgnl(str"MODULE OK: "++prkn(make_kn mp empty_dirpath lab)++fnl());*)
+      Modops.add_module (MPdot(mp,lab)) msb 
+        (add_module_constraints env msb)
+  | SEBmodtype mty ->
+      check_modtype env mty;
+      add_modtype (mp, empty_dirpath, lab) mty
+        (add_modtype_constraints env mty)
+*)
+
+(************************************************************************)
+(*
+ * Global environment
+ *)
+
+let genv = ref empty_env
+let reset () = genv := empty_env
+let get_env () = !genv
+
+let set_engagement c =
+  genv := set_engagement c !genv
+
+(* full_add_module adds module with universes and constraints *)
+let full_add_module dp mb digest =
+  let env = !genv in
+  let mp = MPfile dp in
+  let env = add_module_constraints env mb in
+  let env = Modops.add_module mp mb env in
+  genv := add_digest env dp digest
+
+(* Check that the engagement expected by a library matches the initial one *)
+let check_engagement env c =
+  match engagement env, c with
+    | Some ImpredicativeSet, Some ImpredicativeSet -> ()
+    | _, None -> ()
+    | _, Some ImpredicativeSet ->
+        error "Needs option -impredicative-set"
+
+(* Libraries = Compiled modules *)
+
+let report_clash f caller dir =
+  let msg =
+    str "compiled library " ++ str(string_of_dirpath caller) ++
+    spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++
+    str(string_of_dirpath dir) ++ fnl() in
+  f msg
+
+
+let check_imports f caller env needed =
+  let check (dp,stamp) =
+    try
+      let actual_stamp = lookup_digest env dp in
+      if stamp <> actual_stamp then report_clash f caller dp
+    with Not_found -> 
+      error ("Reference to unknown module " ^ (string_of_dirpath dp))
+  in
+  List.iter check needed
+
+
+
+(* Remove the body of opaque constants in modules *)
+(* also remove mod_expr ? *)
+let rec lighten_module mb =
+  { mb with
+    mod_expr = Option.map lighten_modexpr mb.mod_expr;
+    mod_type = Option.map lighten_modexpr mb.mod_type }
+
+and lighten_struct struc = 
+  let lighten_body (l,body) = (l,match body with
+    | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
+    | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x
+    | SFBmodule m -> SFBmodule (lighten_module m)
+    | SFBmodtype m -> SFBmodtype 
+	({m with 
+	    typ_expr = lighten_modexpr m.typ_expr}))
+  in
+    List.map lighten_body struc
+
+and lighten_modexpr = function
+  | SEBfunctor (mbid,mty,mexpr) ->
+      SEBfunctor (mbid, 
+		    ({mty with 
+			typ_expr = lighten_modexpr mty.typ_expr}),
+		  lighten_modexpr mexpr)
+  | SEBident mp as x -> x
+  | SEBstruct (msid, struc) ->
+      SEBstruct (msid, lighten_struct struc)
+  | SEBapply (mexpr,marg,u) ->
+      SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
+  | SEBwith (seb,wdcl) ->
+      SEBwith (lighten_modexpr seb,wdcl) 
+ 
+let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
+
+
+type compiled_library = 
+    dir_path *
+    module_body *
+    (dir_path * Digest.t) list *
+    engagement option
+ 
+(* When the module is checked, digests do not need to match, but a
+   warning is issued in case of mismatch *)
+let import (dp,mb,depends,engmt as vo) digest = 
+Validate.val_vo (Obj.repr vo);
+prerr_endline "*** vo validated ***";
+  let env = !genv in
+  check_imports msg_warning dp env depends;
+  check_engagement env engmt;
+  check_module env mb;
+  (* We drop proofs once checked *)
+(*  let mb = lighten_module mb in*)
+  full_add_module dp mb digest
+
+(* When the module is admitted, digests *must* match *)
+let unsafe_import (dp,mb,depends,engmt) digest = 
+  let env = !genv in
+  check_imports (errorlabstrm"unsafe_import") dp env depends;
+  check_engagement env engmt;
+  (* We drop proofs once checked *)
+(*  let mb = lighten_module mb in*)
+  full_add_module dp mb digest
diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli
new file mode 100644
index 000000000..81c48ac2a
--- /dev/null
+++ b/checker/safe_typing.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: safe_typing.mli 9821 2007-05-11 17:00:58Z aspiwack $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+(*i*)
+
+val reset : unit -> unit
+val get_env : unit -> env
+
+(* exporting and importing modules *)
+type compiled_library
+
+val set_engagement : Declarations.engagement -> unit
+val import         : compiled_library -> Digest.t -> unit
+val unsafe_import  : compiled_library -> Digest.t -> unit
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
new file mode 100644
index 000000000..fb95b606a
--- /dev/null
+++ b/checker/subtyping.ml
@@ -0,0 +1,388 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: subtyping.ml 10664 2008-03-14 11:27:37Z soubiran $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Reduction
+open Inductive
+open Modops
+(*i*)
+open Pp      
+
+
+
+(* This local type is used to subtype a constant with a constructor or
+   an inductive type. It can also be useful to allow reorderings in
+   inductive types *)
+type namedobject = 
+  | Constant of constant_body
+  | IndType of inductive * mutual_inductive_body
+  | IndConstr of constructor * mutual_inductive_body
+  | Module of module_body
+  | Modtype of module_type_body
+  | Alias of module_path
+
+(* adds above information about one mutual inductive: all types and
+   constructors *)
+
+let add_nameobjects_of_mib ln mib map = 
+  let add_nameobjects_of_one j oib map =
+    let ip = (ln,j) in
+    let map = 
+      array_fold_right_i 
+      (fun i id map ->
+        Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
+      oib.mind_consnames
+      map
+    in
+      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 mp list = 
+  let add_one (l,e) map = 
+   let add_map obj = Labmap.add l obj map in
+   match e with
+    | SFBconst cb -> add_map (Constant cb)
+    | SFBmind mib ->
+       add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map
+    | SFBmodule mb -> add_map (Module mb)
+    | SFBmodtype mtb -> add_map (Modtype mtb)
+    | SFBalias (mp,cst) -> add_map (Alias mp)
+  in
+    List.fold_right add_one list Labmap.empty
+
+let check_conv_error error f env a1 a2 =
+  try
+    f env a1 a2
+  with
+      NotConvertible -> error ()
+
+(* for now we do not allow reorderings *)
+let check_inductive env msid1 l info1 mib2 spec2 = 
+  let kn = make_kn (MPself msid1) empty_dirpath l in
+  let error () = error_not_match l spec2 in
+  let check_conv f = check_conv_error error f in
+  let mib1 = 
+    match info1 with
+      | IndType ((_,0), mib) -> mib
+      | _ -> error ()
+  in
+  let check_inductive_type env t1 t2 =
+
+    (* Due to sort-polymorphism in inductive types, the conclusions of
+       t1 and t2, if in Type, are generated as the least upper bounds
+       of the types of the constructors. 
+
+       By monotonicity of the infered l.u.b.  wrt subtyping (i.e.  if X:U
+       |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
+       universe in the conclusion of t1 has an bounding universe in
+       the conclusion of t2, so that we don't need to check the
+       subtyping of the conclusions of t1 and t2.
+
+       Even if we'd like to recheck it, the inference of constraints
+       is not designed to deal with algebraic constraints of the form
+       max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy
+       to recheck it (in short, we would need the actual graph of
+       constraints as input while type checking is currently designed
+       to output a set of constraints instead) *)
+
+    (* So we cheat and replace the subtyping problem on algebraic
+       constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n)
+       (that we know are necessary true) by trivial constraints that
+       the constraint generator knows how to deal with *)
+
+    let (ctx1,s1) = dest_arity env t1 in
+    let (ctx2,s2) = dest_arity env t2 in
+    let s1,s2 =
+      match s1, s2 with
+      | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null
+      | (Prop _, Type _) | (Type _,Prop _) -> error ()
+      | _ -> (s1, s2) in
+    check_conv conv_leq env 
+      (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+  in
+
+  let check_packet p1 p2 =
+    let check f = if f p1 <> f p2 then error () in
+      check (fun p -> p.mind_consnames);
+      check (fun p -> p.mind_typename);
+      (* nf_lc later *)
+      (* nf_arity later *)
+      (* user_lc ignored *)
+      (* user_arity ignored *)
+      check (fun p -> p.mind_nrealargs);
+      (* kelim ignored *)
+      (* listrec ignored *)
+      (* finite done *)
+      (* nparams done *)
+      (* params_ctxt done because part of the inductive types *)
+      (* Don't check the sort of the type if polymorphic *)
+      check_inductive_type env
+        (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
+  in
+  let check_cons_types i p1 p2 =
+    array_iter2 (check_conv conv env)
+      (arities_of_specif kn (mib1,p1))
+      (arities_of_specif kn (mib2,p2))
+  in
+  let check f = if f mib1 <> f mib2 then error () in
+  check (fun mib -> mib.mind_finite);
+  check (fun mib -> mib.mind_ntypes);
+  assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
+  assert (Array.length mib1.mind_packets >= 1 
+	    && Array.length mib2.mind_packets >= 1);
+
+  (* Check that the expected numbers of uniform parameters are the same *)
+  (* No need to check the contexts of parameters: it is checked *)
+  (* at the time of checking the inductive arities in check_packet. *)
+  (* Notice that we don't expect the local definitions to match: only *)
+  (* the inductive types and constructors types have to be convertible *)
+  check (fun mib -> mib.mind_nparams);
+
+  begin 
+    match mib2.mind_equiv with
+      | None -> ()
+      | Some kn2' -> 
+	  let kn2 = scrape_mind env kn2' in
+	  let kn1 = match mib1.mind_equiv with
+	      None -> kn
+	    | Some kn1' -> scrape_mind env kn1'
+	  in
+	    if kn1 <> kn2 then error ()
+  end;
+  (* we check that records and their field names are preserved. *)
+  check (fun mib -> mib.mind_record);
+  if mib1.mind_record then begin 
+    let rec names_prod_letin t = match t with 
+      | Prod(n,_,t) -> n::(names_prod_letin t)
+      | LetIn(n,_,_,t) -> n::(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); 
+    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
+  end;
+  (* we first check simple things *)
+  array_iter2 check_packet mib1.mind_packets mib2.mind_packets;
+  (* and constructor types in the end *)
+  let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets
+  in ()
+
+let check_constant env msid1 l info1 cb2 spec2 = 
+  let error () = error_not_match l spec2 in
+  let check_conv f = check_conv_error error f in
+  let check_type env t1 t2 = 
+
+    (* If the type of a constant is generated, it may mention
+       non-variable algebraic universes that the general conversion
+       algorithm is not ready to handle. Anyway, generated types of
+       constants are functions of the body of the constant. If the
+       bodies are the same in environments that are subtypes one of
+       the other, the types are subtypes too (i.e. if Gamma <= Gamma',
+       Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
+       Hence they don't have to be checked again *)
+
+    let t1,t2 = 
+      if isArity t2 then
+        let (ctx2,s2) = destArity t2 in
+        match s2 with
+        | Type v when not (is_univ_variable v) ->
+          (* The type in the interface is inferred and is made of algebraic
+             universes *)
+          begin try
+            let (ctx1,s1) = dest_arity env t1 in
+            match s1 with
+            | Type u when not (is_univ_variable u) ->
+              (* Both types are inferred, no need to recheck them. We
+                 cheat and collapse the types to Prop *)
+                mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
+            | Prop _ ->
+              (* The type in the interface is inferred, it may be the case
+                 that the type in the implementation is smaller because
+                 the body is more reduced. We safely collapse the upper
+                 type to Prop *)
+                mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
+            | Type _ ->
+              (* The type in the interface is inferred and the type in the
+                 implementation is not inferred or is inferred but from a
+                 more reduced body so that it is just a variable. Since
+                 constraints of the form "univ <= max(...)" are not
+                 expressible in the system of algebraic universes: we fail
+                 (the user has to use an explicit type in the interface *)
+                error ()
+          with UserError _ (* "not an arity" *) ->
+            error () end
+        | _ -> t1,t2
+      else
+        (t1,t2) in
+    check_conv conv_leq env t1 t2
+  in
+
+  match info1 with
+   | Constant cb1 ->
+      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+      (*Start by checking types*)
+      let typ1 = Typeops.type_of_constant_type env cb1.const_type in
+      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+      check_type env typ1 typ2;
+      let con = make_con (MPself msid1) empty_dirpath l in
+      (match cb2 with
+        | {const_body=Some lc2;const_opaque=false} ->
+	    let c2 = force_constr lc2 in
+	    let c1 = match cb1.const_body with
+	      | Some lc1 -> force_constr lc1
+	      | None -> Const con
+	    in
+	       check_conv conv env c1 c2
+        | _ -> ())
+   | IndType ((kn,i),mind1) ->
+      ignore (Util.error (
+       "The kernel does not recognize yet that a parameter can be " ^
+       "instantiated by an inductive type. Hint: you can rename the " ^
+       "inductive type and give a definition to map the old name to the new " ^
+       "name."));
+      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
+      if cb2.const_body <> None then error () ;
+      let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
+      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+       check_conv conv_leq env arity1 typ2
+   | IndConstr (((kn,i),j) as cstr,mind1) ->
+      ignore (Util.error (
+       "The kernel does not recognize yet that a parameter can be " ^
+       "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
+      let ty2 = Typeops.type_of_constant_type env cb2.const_type in
+       check_conv conv env ty1 ty2
+   | _ -> error ()
+
+let rec check_modules env msid1 l msb1 msb2 =
+  let mp = (MPdot(MPself msid1,l)) in
+  let mty1 = module_type_of_module (Some mp) msb1 in
+  let mty2 =  module_type_of_module None msb2 in
+  check_modtypes env mty1 mty2 false
+	
+
+and check_signatures env (msid1,sig1) alias (msid2,sig2') = 
+  let mp1 = MPself msid1 in
+  let env = add_signature mp1 sig1 env in 
+  let alias = update_subst_alias alias (map_msid msid2 mp1) in
+  let sig2 = subst_structure alias sig2' in
+  let sig2 = subst_signature_msid msid2 mp1 sig2 in
+  let map1 = make_label_map mp1 sig1 in
+  let check_one_body (l,spec2) = 
+    let info1 = 
+      try 
+	Labmap.find l map1 
+      with 
+	  Not_found -> error_no_such_label_sub l msid1 msid2
+    in
+      match spec2 with
+	| SFBconst cb2 ->
+	    check_constant env msid1 l info1 cb2 spec2
+	| SFBmind mib2 -> 
+	    check_inductive env msid1 l info1 mib2 spec2
+	| SFBmodule msb2 ->  
+	    begin
+	      match info1 with
+		| Module msb -> check_modules env msid1 l msb msb2
+		| Alias mp ->let msb = 
+		    {mod_expr = Some (SEBident mp);
+		     mod_type = Some (eval_struct env (SEBident mp));
+		     mod_constraints = Constraint.empty;
+		     mod_alias = (lookup_modtype mp env).typ_alias;
+		     mod_retroknowledge = []} in
+		    check_modules env msid1 l msb msb2
+		| _ -> error_not_match l spec2
+	    end
+	| SFBalias (mp,_) ->
+	    begin	
+	      match info1 with
+		| Alias mp1 -> check_modpath_equiv env mp mp1
+		| Module msb -> 
+		    let msb1 = 
+		      {mod_expr = Some (SEBident mp);
+		       mod_type = Some (eval_struct env (SEBident mp));
+		       mod_constraints = Constraint.empty;
+		       mod_alias = (lookup_modtype mp env).typ_alias;
+		       mod_retroknowledge = []} in
+			check_modules env msid1 l msb msb1
+		| _ -> error_not_match l spec2
+	    end
+	| SFBmodtype mtb2 ->
+	    let mtb1 = 
+	      match info1 with
+		| Modtype mtb -> mtb
+		| _ -> error_not_match l spec2
+	    in
+	      check_modtypes env mtb1 mtb2 true
+  in
+    List.iter check_one_body sig2
+
+and check_modtypes env mtb1 mtb2 equiv = 
+  if mtb1==mtb2 then () else (* just in case  :) *)
+  let mtb1',mtb2'=
+    (match mtb1.typ_strength with
+	 None -> eval_struct env mtb1.typ_expr,
+	   eval_struct env mtb2.typ_expr
+       | Some mp -> strengthen  env mtb1.typ_expr mp,
+	   eval_struct env mtb2.typ_expr) in
+      let rec check_structure env str1 str2 equiv = 
+	match str1, str2 with
+	  | SEBstruct (msid1,list1), 
+	    SEBstruct (msid2,list2) -> 
+	      check_signatures env
+		(msid1,list1) mtb1.typ_alias (msid2,list2);
+	      if equiv then
+		check_signatures env 
+		  (msid2,list2) mtb2.typ_alias  (msid1,list1) 
+	  | SEBfunctor (arg_id1,arg_t1,body_t1), 
+	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
+	      check_modtypes env arg_t2 arg_t1 equiv;
+		(* contravariant *)
+	      let env = 
+		add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	      in
+	      let body_t1' = 
+		(* since we are just checking well-typedness we do not need
+		   to expand any constant. Hence the identity resolver. *)
+		subst_struct_expr
+		  (map_mbid arg_id1 (MPbound arg_id2))
+		  body_t1
+	      in
+		check_structure env (eval_struct env body_t1')
+		  (eval_struct env body_t2) equiv
+	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+      in 
+     if mtb1'== mtb2' then ()
+     else check_structure env mtb1' mtb2' equiv
+
+let check_subtypes env sup super = 
+  (*if sup<>super then*)
+  check_modtypes env sup super false
+	  
+let check_equal env sup super = 
+  (*if sup<>super then*)
+  check_modtypes env sup super true
diff --git a/checker/subtyping.mli b/checker/subtyping.mli
new file mode 100644
index 000000000..10842252e
--- /dev/null
+++ b/checker/subtyping.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+
+(*i*)
+open Univ
+open Term
+open Declarations
+open Environ
+(*i*)
+
+val check_subtypes : env -> module_type_body -> module_type_body -> unit
+val check_equal : env -> module_type_body -> module_type_body -> unit
+
+
diff --git a/checker/term.ml b/checker/term.ml
new file mode 100644
index 000000000..9e4249396
--- /dev/null
+++ b/checker/term.ml
@@ -0,0 +1,461 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: term.ml 10098 2007-08-27 11:41:08Z herbelin $ *)
+
+(* This module instantiates the structure of generic deBruijn terms to Coq *)
+
+open Util
+open Pp
+open Names
+open Univ
+open Esubst
+
+(* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *)
+
+type existential_key = int
+type metavariable = int
+
+(* This defines the strategy to use for verifiying a Cast *)
+
+(* This defines Cases annotations *)
+type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_nargs : int; (* number of real args of the inductive type *)
+    style     : case_style }
+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 *)
+  }
+
+(* Sorts. *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents                      (* proposition types *)
+  | Type of universe
+
+type sorts_family = InProp | InSet | InType
+
+let family_of_sort = function
+  | Prop Null -> InProp
+  | Prop Pos -> InSet
+  | Type _ -> InType
+
+(********************************************************************)
+(*       Constructions as implemented                               *)
+(********************************************************************)
+
+(* [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type 'constr prec_declaration =
+    name array * 'constr array * 'constr array
+type 'constr pfixpoint =
+    (int array * int) * 'constr prec_declaration
+type 'constr pcofixpoint =
+    int * 'constr prec_declaration
+
+type cast_kind = VMcast | DEFAULTcast 
+
+(*s*******************************************************************)
+(* The type of constructions *)
+
+type constr =
+  | Rel       of int
+  | Var       of identifier
+  | Meta      of metavariable
+  | Evar      of constr pexistential
+  | Sort      of sorts
+  | Cast      of constr * cast_kind * constr
+  | Prod      of name * constr * constr
+  | Lambda    of name * constr * constr
+  | LetIn     of name * constr * constr * constr
+  | App       of constr * constr array
+  | Const     of constant
+  | Ind       of inductive
+  | Construct of constructor
+  | Case      of case_info * constr * constr * constr array
+  | Fix       of constr pfixpoint
+  | CoFix     of constr pcofixpoint
+
+type existential = constr pexistential
+type rec_declaration = constr prec_declaration
+type fixpoint = constr pfixpoint
+type cofixpoint = constr pcofixpoint
+
+let rec strip_outer_cast c = match c with
+  | Cast (c,_,_) -> strip_outer_cast c
+  | _ -> c
+
+let rec collapse_appl c = match c with
+  | App (f,cl) -> 
+      let rec collapse_rec f cl2 =
+        match (strip_outer_cast f) with
+	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
+	| _ -> App (f,cl2)
+      in
+      collapse_rec f cl
+  | _ -> c
+
+let decompose_app c =
+  match collapse_appl c with
+    | App (f,cl) -> (f, Array.to_list cl)
+    | _ -> (c,[])
+
+
+let applist (f,l) = App (f, Array.of_list l)
+
+
+(****************************************************************************)
+(*              Functions for dealing with constr terms                     *)
+(****************************************************************************)
+
+(*********************)
+(*     Occurring     *)
+(*********************)
+
+let iter_constr_with_binders g f n c = match c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,_,t) -> f n c; f n t
+  | Prod (_,t,c) -> f n t; f (g n) c
+  | Lambda (_,t,c) -> f n t; f (g n) c
+  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
+  | App (c,l) -> f n c; Array.iter (f n) l
+  | Evar (_,l) -> Array.iter (f n) l
+  | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
+  | Fix (_,(_,tl,bl)) -> 
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+  | CoFix (_,(_,tl,bl)) ->
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+
+exception LocalOccur
+
+(* (closedn n M) raises FreeVar if a variable of height greater than n
+   occurs in M, returns () otherwise *)
+
+let closedn n c = 
+  let rec closed_rec n c = match c with
+    | Rel m -> if m>n then raise LocalOccur
+    | _ -> iter_constr_with_binders succ closed_rec n c
+  in 
+  try closed_rec n c; true with LocalOccur -> false
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+
+let closed0 = closedn 0
+
+(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
+
+let noccurn n term = 
+  let rec occur_rec n c = match c with
+    | Rel m -> if m = n then raise LocalOccur
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M 
+  for n <= p < n+m *)
+
+let noccur_between n m term = 
+  let rec occur_rec n c = match c with
+    | Rel(p) -> if n<=p && p<n+m then raise LocalOccur
+    | _        -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* Checking function for terms containing existential variables.
+ The function [noccur_with_meta] considers the fact that
+ each existential variable (as well as each isevar)
+ in the term appears applied to its local context,
+ which may contain the CoFix variables. These occurrences of CoFix variables
+ are not considered *)
+
+let noccur_with_meta n m term = 
+  let rec occur_rec n c = match c with
+    | Rel p -> if n<=p & p<n+m then raise LocalOccur
+    | App(f,cl) ->
+	(match f with
+           | (Cast (Meta _,_,_)| Meta _) -> ()
+	   | _ -> iter_constr_with_binders succ occur_rec n c)
+    | Evar (_, _) -> ()
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in
+  try (occur_rec n term; true) with LocalOccur -> false
+
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+let map_constr_with_binders g f l c = match c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (c,k,t) -> Cast (f l c, k, f l t)
+  | Prod (na,t,c) -> Prod (na, f l t, f (g l) c)
+  | Lambda (na,t,c) -> Lambda (na, f l t, f (g l) c)
+  | LetIn (na,b,t,c) -> LetIn (na, f l b, f l t, f (g l) c)
+  | App (c,al) -> App (f l c, Array.map (f l) al)
+  | Evar (e,al) -> Evar (e, Array.map (f l) al)
+  | Case (ci,p,c,bl) -> Case (ci, f l p, f l c, Array.map (f l) bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      let l' = iterate g (Array.length tl) l in
+      Fix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let l' = iterate g (Array.length tl) l in
+      CoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+
+(* The generic lifting function *)
+let rec exliftn el c = match c with
+  | Rel i -> Rel(reloc_rel i el)
+  | _ -> map_constr_with_binders el_lift exliftn el c
+
+(* Lifting the binding depth across k bindings *)
+
+let liftn k n = 
+  match el_liftn (pred n) (el_shft k ELID) with
+    | ELID -> (fun c -> c)
+    | el -> exliftn el
+ 
+let lift k = liftn k 1
+
+(*********************)
+(*   Substituting    *)
+(*********************)
+
+(* (subst1 M c) substitutes M for Rel(1) in c 
+   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
+   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
+
+(* 1st : general case *)
+type info = Closed | Open | Unknown
+type 'a substituend = { mutable sinfo: info; sit: 'a }
+
+let rec lift_substituend depth s =
+  match s.sinfo with
+    | Closed -> s.sit
+    | Open -> lift depth s.sit
+    | Unknown ->
+        s.sinfo <- if closed0 s.sit then Closed else Open;
+        lift_substituend depth s
+
+let make_substituend c = { sinfo=Unknown; sit=c }
+
+let substn_many lamv n c =
+  let lv = Array.length lamv in 
+  if lv = 0 then c
+  else 
+    let rec substrec depth c = match c with
+      | Rel k     ->
+          if k<=depth then c
+          else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
+          else Rel (k-lv)
+      | _ -> map_constr_with_binders succ substrec depth c in 
+    substrec n c
+
+let substnl laml n =
+  substn_many (Array.map make_substituend (Array.of_list laml)) n
+let substl laml = substnl laml 0
+let subst1 lam = substl [lam]
+
+
+(***************************************************************************)
+(*     Type of assumptions and contexts                                    *)
+(***************************************************************************)
+
+type named_declaration = identifier * constr option * constr
+type rel_declaration = name * constr option * constr
+
+let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty)
+let map_rel_declaration = map_named_declaration
+
+let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
+let fold_rel_declaration = fold_named_declaration
+
+
+type named_context = named_declaration list
+let empty_named_context = []
+let fold_named_context f l ~init = List.fold_right f l init
+
+type section_context = named_context
+
+type rel_context = rel_declaration list
+let empty_rel_context = []
+let rel_context_length = List.length
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 hyps
+let fold_rel_context f l ~init = List.fold_right f l init
+
+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
+      if body_o' == body_o && typ' == typ then decl else
+	(n, body_o', typ')
+  in
+    list_smartmap map_decl l
+
+let map_rel_context = map_context
+
+let extended_rel_list n hyps =
+  let rec reln l p = function
+    | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
+    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | [] -> l
+  in 
+  reln [] 1 hyps
+
+(* Iterate lambda abstractions *)
+
+(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *)
+let compose_lam l b =
+  let rec lamrec = function
+    | ([], b)       -> b
+    | ((v,t)::l, b) -> lamrec (l, Lambda (v,t,b))
+  in 
+  lamrec (l,b)
+
+(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
+let decompose_lam = 
+  let rec lamdec_rec l c = match c with
+    | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
+    | Cast (c,_,_)     -> lamdec_rec l c
+    | _                -> l,c
+  in 
+  lamdec_rec []
+
+(* Decompose lambda abstractions and lets, until finding n
+  abstractions *)
+let decompose_lam_n_assum n =
+  if n < 0 then
+    error "decompose_lam_n_assum: integer parameter must be positive";
+  let rec lamdec_rec l n c = 
+    if n=0 then l,c 
+    else match c with 
+    | Lambda (x,t,c)  -> lamdec_rec ((x,None,t) :: l) (n-1) c
+    | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: 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 
+
+(* Iterate products, with or without lets *)
+
+(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+let mkProd_or_LetIn (na,body,t) c =
+  match body with
+    | None -> Prod (na, t, c)
+    | Some b -> LetIn (na, b, t, c)
+
+let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
+
+let decompose_prod_assum = 
+  let rec prodec_rec l c =
+    match 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
+    | _               -> l,c
+  in 
+  prodec_rec empty_rel_context
+
+let decompose_prod_n_assum n =
+  if n < 0 then
+    error "decompose_prod_n_assum: integer parameter must be positive";
+  let rec prodec_rec l n c = 
+    if n=0 then l,c
+    else match c with 
+    | Prod (x,t,c)    -> prodec_rec ((x,None,t) :: l) (n-1) c
+    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c
+    | Cast (c,_,_)    -> prodec_rec l n c
+    | c -> error "decompose_prod_n_assum: not enough assumptions"
+  in 
+  prodec_rec empty_rel_context n
+
+
+(***************************)
+(* Other term constructors *)
+(***************************)
+
+type arity = rel_context * sorts
+
+let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign
+
+let destArity = 
+  let rec prodec_rec l c =
+    match c with
+    | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
+    | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
+    | Cast (c,_,_)    -> prodec_rec l c
+    | Sort s          -> l,s
+    | _               -> anomaly "destArity: not an arity"
+  in 
+  prodec_rec []
+
+let rec isArity c =
+  match c with
+  | Prod (_,_,c)    -> isArity c
+  | LetIn (_,b,_,c) -> isArity (subst1 b c)
+  | Cast (c,_,_)    -> isArity c
+  | Sort _          -> true
+  | _               -> false
+
+(*******************************)
+(*  alpha conversion functions *)                         
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let compare_constr f t1 t2 =
+  match t1, t2 with
+  | Rel n1, Rel n2 -> n1 = n2
+  | Meta m1, Meta m2 -> m1 = m2
+  | Var id1, Var id2 -> id1 = id2
+  | Sort s1, Sort s2 -> s1 = s2
+  | Cast (c1,_,_), _ -> f c1 t2
+  | _, Cast (c2,_,_) -> f t1 c2
+  | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
+  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
+  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
+  | App (c1,l1), App (c2,l2) ->
+      if Array.length l1 = Array.length l2 then
+        f c1 c2 & array_for_all2 f l1 l2
+      else
+        let (h1,l1) = decompose_app t1 in        
+        let (h2,l2) = decompose_app t2 in
+        if List.length l1 = List.length l2 then
+          f h1 h2 & List.for_all2 f l1 l2
+        else false
+  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
+  | Const c1, Const c2 -> c1 = c2
+  | Ind c1, Ind c2 -> c1 = c2
+  | Construct c1, Construct c2 -> c1 = c2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
+  | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | _ -> false
+
+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 *)
diff --git a/checker/type_errors.ml b/checker/type_errors.ml
new file mode 100644
index 000000000..a96bba6a4
--- /dev/null
+++ b/checker/type_errors.ml
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: type_errors.ml 8845 2006-05-23 07:41:58Z herbelin $ *)
+
+open Names
+open Term
+open Environ
+
+type unsafe_judgment = constr * constr
+
+let nf_betaiota c = c
+
+(* Type errors. *)
+
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType of constr
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+      * (sorts_family * sorts_family * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * constr) * unsafe_judgment
+  | ActualType of unsafe_judgment * constr
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * constr array
+
+exception TypeError of env * type_error
+
+let nfj (c,ct) = (c, nf_betaiota ct)
+
+let error_unbound_rel env n =
+  raise (TypeError (env, UnboundRel n))
+
+let error_unbound_var env v =
+  raise (TypeError (env, UnboundVar v))
+
+let error_not_type env j =
+  raise (TypeError (env, NotAType j))
+
+let error_assumption env j =
+  raise (TypeError (env, BadAssumption j))
+
+let error_reference_variables env id =
+  raise (TypeError (env, ReferenceVariables id))
+
+let error_elim_arity env ind aritylst c pj okinds = 
+  raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
+
+let error_case_not_inductive env j = 
+  raise (TypeError (env, CaseNotInductive j))
+
+let error_number_branches env cj expn =
+  raise (TypeError (env, NumberBranches (nfj cj,expn)))
+
+let error_ill_formed_branch env c i actty expty =
+  raise (TypeError (env,
+    IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
+
+let error_generalization env nvar c =
+  raise (TypeError (env, Generalization (nvar,c)))
+
+let error_actual_type env j expty =
+  raise (TypeError (env, ActualType (j,expty)))
+
+let error_cant_apply_not_functional env rator randl =
+  raise (TypeError (env, CantApplyNonFunctional (rator,randl)))
+
+let error_cant_apply_bad_type env t rator randl =
+  raise (TypeError (env, CantApplyBadType (t,rator,randl)))
+
+let error_ill_formed_rec_body env why lna i =
+  raise (TypeError (env, IllFormedRecBody (why,lna,i)))
+
+let error_ill_typed_rec_body env i lna vdefj vargs =
+  raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
+
+
diff --git a/checker/type_errors.mli b/checker/type_errors.mli
new file mode 100644
index 000000000..2d8f8ff22
--- /dev/null
+++ b/checker/type_errors.mli
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: type_errors.mli 8845 2006-05-23 07:41:58Z herbelin $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+(*i*)
+
+type unsafe_judgment = constr * constr
+
+(* Type errors. \label{typeerrors} *)
+
+(*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
+    notation i*)
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType of constr
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+      * (sorts_family * sorts_family * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * constr) * unsafe_judgment
+  | ActualType of unsafe_judgment * constr
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * constr array
+
+exception TypeError of env * type_error
+
+val error_unbound_rel : env -> int -> 'a
+
+val error_unbound_var : env -> variable -> 'a
+
+val error_not_type : env -> unsafe_judgment -> 'a
+
+val error_assumption : env -> unsafe_judgment -> 'a
+ 
+val error_reference_variables : env -> constr -> 'a
+
+val error_elim_arity : 
+  env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> 
+      (sorts_family * sorts_family * arity_error) option -> 'a
+
+val error_case_not_inductive : env -> unsafe_judgment -> 'a
+
+val error_number_branches : env -> unsafe_judgment -> int -> 'a
+
+val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
+
+val error_generalization : env -> name * constr -> unsafe_judgment -> 'a
+
+val error_actual_type : env -> unsafe_judgment -> constr -> 'a
+
+val error_cant_apply_not_functional : 
+  env -> unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_cant_apply_bad_type : 
+  env -> int * constr * constr -> 
+      unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_ill_formed_rec_body :
+  env -> guard_error -> name array -> int -> 'a
+
+val error_ill_typed_rec_body  :
+  env -> int -> name array -> unsafe_judgment array -> constr array -> 'a
+
diff --git a/checker/typeops.ml b/checker/typeops.ml
new file mode 100644
index 000000000..5b289e0e1
--- /dev/null
+++ b/checker/typeops.ml
@@ -0,0 +1,438 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: typeops.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Type_errors
+open Declarations
+open Inductive
+open Environ
+
+let inductive_of_constructor = fst
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i _ t1 t2 ->
+      (try conv_leq env t1 t2 
+      with NotConvertible -> raise (NotConvertibleVect i)); ())
+    ()
+    v1
+    v2
+
+(* This should be a type (a priori without intension to be an assumption) *)
+let type_judgment env (c,ty as j) =
+  match whd_betadeltaiota env ty with
+    | Sort s -> (c,s)
+    | _ -> error_not_type env j
+
+(* This should be a type intended to be assumed. The error message is *)
+(* not as useful as for [type_judgment]. *)
+let assumption_of_judgment env j =
+  try fst(type_judgment env j)
+  with TypeError _ ->
+    error_assumption env j
+
+(************************************************)
+(* Incremental typing rules: builds a typing judgement given the *)
+(* judgements for the subterms. *)
+
+(*s Type of sorts *)
+
+(* Prop and Set *)
+
+let judge_of_prop = Sort (Type prop_univ)
+
+(* Type of Type(i). *)
+
+let judge_of_type u = Sort (Type (super u))
+
+(*s Type of a de Bruijn index. *)
+	  
+let judge_of_relative env n = 
+  try
+    let (_,_,typ) = lookup_rel n env in
+    lift n typ
+  with Not_found -> 
+    error_unbound_rel env n
+
+(* Type of variables *)
+let judge_of_variable env id =
+  try named_type id env
+  with Not_found -> 
+    error_unbound_var env id
+
+(* Management of context of variables. *)
+
+(* 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 =
+  fold_named_context
+    (fun (id,_,ty1) () ->
+      let ty2 = named_type id env in
+      if not (eq_constr ty2 ty1) then
+        error "types do not match")
+    sign
+    ~init:()
+
+
+let check_args env c hyps =
+  try check_hyps_inclusion env hyps
+  with UserError _ | Not_found ->
+    error_reference_variables env c
+
+
+(* Checks if the given context of variables [hyps] is included in the
+   current context of [env]. *)
+(*
+let check_hyps id env hyps =
+  let hyps' = named_context env in
+  if not (hyps_inclusion env hyps hyps') then
+    error_reference_variables env id
+*)
+(* Instantiation of terms on real arguments. *)
+
+(* Make a type polymorphic if an arity *)
+
+let extract_level env p =
+  let _,c = dest_prod_assum env p in
+  match c with Sort (Type u) -> Some u | _ -> None
+
+let extract_context_levels env =
+  List.fold_left
+    (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
+
+let make_polymorphic_if_arity env t =
+  let params, ccl = dest_prod_assum env t in
+  match ccl with
+  | Sort (Type u) -> 
+      let param_ccls = extract_context_levels env params in
+      let s = { poly_param_levels = param_ccls; poly_level = u} in
+      PolymorphicArity (params,s)
+  | _ ->
+      NonPolymorphicType t
+
+(* Type of constants *)
+
+let type_of_constant_knowing_parameters env t paramtyps =
+  match t with
+  | NonPolymorphicType t -> t
+  | PolymorphicArity (sign,ar) ->
+      let ctx = List.rev sign in
+      let ctx,s = instantiate_universes env ctx ar paramtyps in
+      mkArity (List.rev ctx,s)
+
+let type_of_constant_type env t =
+  type_of_constant_knowing_parameters env t [||]
+
+let type_of_constant env cst =
+  type_of_constant_type env (constant_type env cst)
+
+let judge_of_constant_knowing_parameters env cst paramstyp =
+  let c = Const cst in
+  let cb = lookup_constant cst env in
+  let _ = check_args env c cb.const_hyps in 
+  type_of_constant_knowing_parameters env cb.const_type paramstyp
+
+let judge_of_constant env cst =
+  judge_of_constant_knowing_parameters env cst [||]
+
+(* Type of an application. *)
+
+let judge_of_apply env (f,funj) argjv =
+  let rec apply_rec n typ = function
+    | [] -> typ
+    | (h,hj)::restjl ->
+        (match whd_betadeltaiota env typ with
+          | Prod (_,c1,c2) ->
+	      (try conv_leq env hj c1
+	      with NotConvertible -> 
+		error_cant_apply_bad_type env (n,c1, hj) (f,funj) argjv);
+	      apply_rec (n+1) (subst1 h c2) restjl
+          | _ ->
+	      error_cant_apply_not_functional env (f,funj) argjv)
+  in 
+  apply_rec 1 funj (Array.to_list argjv)
+
+(* Type of product *)
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *) 
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        if engagement env = Some ImpredicativeSet then
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        else
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          Type (sup u1 base_univ)
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (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)
+
+(* Type of a type cast *)
+
+(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
+
+    env |- c:typ1    env |- typ2:s    env |- typ1 <= typ2
+    ---------------------------------------------------------------------
+         env |- c:typ2
+*)
+
+let judge_of_cast env (c,cj) k tj =
+  let conversion =
+    match k with
+    | VMcast -> vm_conv CUMUL
+    | DEFAULTcast -> conv_leq in
+  try 
+    conversion env cj tj
+  with NotConvertible ->
+    error_actual_type env (c,cj) tj
+
+(* Inductive types. *)
+
+(* The type is parametric over the uniform parameters whose conclusion
+   is in Type; to enforce the internal constraints between the
+   parameters and the instances of Type occurring in the type of the
+   constructors, we use the level variables _statically_ assigned to
+   the conclusions of the parameters as mediators: e.g. if a parameter
+   has conclusion Type(alpha), static constraints of the form alpha<=v
+   exist between alpha and the Type's occurring in the constructor
+   types; when the parameters is finally instantiated by a term of
+   conclusion Type(u), then the constraints u<=alpha is computed in
+   the App case of execute; from this constraints, the expected
+   dynamic constraints of the form u<=v are enforced *)
+
+let judge_of_inductive_knowing_parameters env ind (paramstyp:constr array) =
+  let c = Ind ind in
+  let (mib,mip) = lookup_mind_specif env ind in
+  check_args env c mib.mind_hyps;
+  type_of_inductive_knowing_parameters env mip paramstyp
+
+let judge_of_inductive env ind =
+  judge_of_inductive_knowing_parameters env ind [||]
+
+(* Constructors. *)
+
+let judge_of_constructor env c =
+  let constr = Construct c in
+  let _ =
+    let ((kn,_),_) = c in
+    let mib = lookup_mind kn env in
+    check_args env constr mib.mind_hyps in 
+  let specif = lookup_mind_specif env (inductive_of_constructor c) in
+  type_of_constructor c specif
+
+(* Case. *)
+
+let check_branch_types env (c,cj) (lfj,explft) = 
+  try conv_leq_vecti env lfj explft
+  with
+      NotConvertibleVect i ->
+        error_ill_formed_branch env c i lfj.(i) explft.(i)
+    | Invalid_argument _ ->
+        error_number_branches env (c,cj) (Array.length explft)
+
+let judge_of_case env ci pj (c,cj) lfj =
+  let indspec =
+    try find_rectype env cj
+    with Not_found -> error_case_not_inductive env (c,cj) in
+  let _ = check_case_info env (fst indspec) ci in
+  let (bty,rslty) = type_case_branches env indspec pj c in
+  check_branch_types env (c,cj) (lfj,bty);
+  rslty
+
+(* Fixpoints. *)
+
+(* Checks the type of a general (co)fixpoint, i.e. without checking *)
+(* the specific guard condition. *)
+
+let type_fixpoint env lna lar lbody vdefj =
+  let lt = Array.length vdefj in
+  assert (Array.length lar = lt && Array.length lbody = lt);
+  try
+    conv_leq_vecti env vdefj (Array.map (fun ty -> lift lt ty) lar)
+  with NotConvertibleVect i ->
+    let vdefj = array_map2 (fun b ty -> b,ty) lbody vdefj in
+    error_ill_typed_rec_body env i lna vdefj lar
+
+(************************************************************************)
+(************************************************************************)
+
+
+let refresh_arity env ar =
+  let ctxt, hd = decompose_prod_assum ar in
+  match hd with
+      Sort (Type u) when not (is_univ_variable u) ->
+        let u' = fresh_local_univ() in
+        let env' = add_constraints (enforce_geq u' u Constraint.empty) env in
+        env', mkArity (ctxt,Type u')
+    | _ -> env, ar
+
+
+(* The typing machine. *)
+let rec execute env cstr =
+  match cstr with
+    (* Atomic terms *)
+    | Sort (Prop _) -> judge_of_prop
+
+    | Sort (Type u) -> judge_of_type u
+
+    | Rel n -> judge_of_relative env n
+
+    | Var id -> judge_of_variable env id
+
+    | Const c -> judge_of_constant env c
+
+    (* Lambda calculus operators *)
+    | App (App (f,args),args') ->
+        execute env (App(f,Array.append args args'))
+
+    | App (f,args) ->
+        let jl = execute_array env args in
+	let j =
+	  match f with
+	    | Ind ind ->
+		(* Sort-polymorphism of inductive types *)
+		judge_of_inductive_knowing_parameters env ind jl
+	    | Const cst -> 
+		(* Sort-polymorphism of constant *)
+		judge_of_constant_knowing_parameters env cst jl
+	    | _ -> 
+		(* No sort-polymorphism *)
+		execute env f
+	in
+        let jl = array_map2 (fun c ty -> c,ty) args jl in
+	judge_of_apply env (f,j) jl
+	    
+    | Lambda (name,c1,c2) -> 
+        let _ = execute_type env c1 in
+	let env1 = push_rel (name,None,c1) env in
+        let j' = execute env1 c2 in 
+        Prod(name,c1,j')
+	  
+    | Prod (name,c1,c2) ->
+        let varj = execute_type env c1 in
+	let env1 = push_rel (name,None,c1) env in
+        let varj' = execute_type env1 c2 in
+	Sort (sort_of_product env varj varj')
+
+    | LetIn (name,c1,c2,c3) ->
+        let j1 = execute env c1 in
+        (* /!\ c2 can be an inferred type => refresh
+           (but the pushed type is still c2) *)
+        let _ =
+          let env',c2' = refresh_arity env c2 in
+          let _ = execute_type env' c2' in
+          judge_of_cast env' (c1,j1) DEFAULTcast c2' in
+        let env1 = push_rel (name,Some c1,c2) env in
+        let j' = execute env1 c3 in
+        subst1 c1 j'
+	  
+    | Cast (c,k,t) ->
+        let cj = execute env c in
+        let _ = execute_type env t in
+	judge_of_cast env (c,cj) k t;
+        t
+
+    (* Inductive types *)
+    | Ind ind -> judge_of_inductive env ind
+
+    | Construct c -> judge_of_constructor env c
+
+    | Case (ci,p,c,lf) ->
+        let cj = execute env c in
+        let pj = execute env p in
+        let lfj = execute_array env lf in
+        judge_of_case env ci (p,pj) (c,cj) lfj
+  
+    | Fix ((_,i as vni),recdef) ->
+        let fix_ty = execute_recdef env recdef i in
+        let fix = (vni,recdef) in
+        check_fix env fix;
+	fix_ty
+	  
+    | CoFix (i,recdef) ->
+        let fix_ty = execute_recdef env recdef i in
+        let cofix = (i,recdef) in
+        check_cofix env cofix;
+	fix_ty
+
+    (* Partial proofs: unsupported by the kernel *)
+    | Meta _ ->
+	anomaly "the kernel does not support metavariables"
+
+    | Evar _ ->
+	anomaly "the kernel does not support existential variables"
+
+and execute_type env constr = 
+  let j = execute env constr in
+  snd (type_judgment env (constr,j))
+	  
+and execute_recdef env (names,lar,vdef) i =
+  let larj = execute_array env lar in
+  let larj = array_map2 (fun c ty -> c,ty) lar larj in
+  let lara = Array.map (assumption_of_judgment env) larj in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let vdefj = execute_array env1 vdef in
+  type_fixpoint env1 names lara vdef vdefj;
+  lara.(i)
+
+and execute_array env = Array.map (execute env)
+
+and execute_list env = List.map (execute env) 
+
+(* Derived functions *)
+let infer env constr = execute env constr
+let infer_type env constr = execute_type env constr
+let infer_v env cv = execute_array env cv
+
+(* Typing of several terms. *)
+
+let check_ctxt env rels =
+  fold_rel_context (fun d env ->
+    match d with
+        (_,None,ty) -> 
+          let _ = infer_type env ty in
+          push_rel d env
+      | (_,Some bd,ty) ->
+          let j1 = infer env bd in
+          let _ = infer env ty in
+          conv_leq env j1 ty;
+          push_rel d env)
+    rels ~init:env
+
+let check_named_ctxt env ctxt =
+  fold_named_context (fun (id,_,_ as d) env ->
+    let _ =
+      try
+        let _ = lookup_named id env in
+        failwith ("variable "^string_of_id id^" defined twice")
+      with Not_found -> () in
+    match d with
+        (_,None,ty) -> 
+          let _ = infer_type env ty in
+          push_named d env
+      | (_,Some bd,ty) ->
+          let j1 = infer env bd in
+          let _ = infer env ty in
+          conv_leq env j1 ty;
+          push_named d env)
+    ctxt ~init:env
diff --git a/checker/typeops.mli b/checker/typeops.mli
new file mode 100644
index 000000000..6723d82fc
--- /dev/null
+++ b/checker/typeops.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typeops.mli 9427 2006-12-11 18:46:35Z bgregoir $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Environ
+(*i*)
+
+(*s Typing functions (not yet tagged as safe) *)
+
+val infer      : env -> constr      -> constr
+val infer_type : env -> constr      -> sorts
+val check_ctxt : env -> rel_context -> env
+val check_named_ctxt : env -> named_context -> env
+
+val type_of_constant_type : env -> constant_type -> constr
+
diff --git a/checker/validate.ml b/checker/validate.ml
new file mode 100644
index 000000000..2eb1ec0cf
--- /dev/null
+++ b/checker/validate.ml
@@ -0,0 +1,222 @@
+
+let rec pr_obj o =
+  if Obj.is_int o then
+    Format.print_string ("INT:"^string_of_int(Obj.magic o))
+  else if Obj.is_block o then
+    let t = Obj.tag o in
+    if t > Obj.no_scan_tag then
+      if t = Obj.string_tag then
+        Format.print_string ("STR:"^Obj.magic o)
+      else
+        Format.print_string "?"
+    else
+      (let n = Obj.size o in
+      Format.print_string ("#"^string_of_int t^"(");
+      Format.open_hvbox 0;
+      for i = 0 to n-1 do
+        pr_obj (Obj.field o i);
+        if i<>n-1 then (Format.print_string ","; Format.print_cut())
+      done;
+      Format.close_box();
+      Format.print_string ")")
+  else Format.print_string "?"
+
+let pr_obj o = pr_obj o; Format.print_newline()
+
+
+
+let no_val (o:Obj.t) = ()
+
+let val_tag t o =
+  if Obj.is_block o && Obj.tag o = t then ()
+  else failwith ("tag "^string_of_int t)
+
+let val_tuple s v o =
+  let n = Array.length v in
+  if Obj.is_block o then
+    if Obj.size o = n then
+      Array.iteri (fun i f -> f (Obj.field o i)) v
+    else
+      (pr_obj o;
+       failwith
+         ("tuple:" ^s^" size found:"^string_of_int (Obj.size o)))
+  else failwith ("tuple:" ^s)
+
+let val_sum s cc vv o =
+  if Obj.is_block o then
+    let n = Array.length vv in
+    let i = Obj.tag o in
+    if i < n then val_tuple (s^"("^string_of_int i^")") vv.(i) o
+    else failwith ("bad tag in sum: "^string_of_int i)
+  else if Obj.is_int o then
+    let (n:int) = Obj.magic o in
+    (if n<0 || n>=cc then failwith "bad constant constructor")
+  else failwith "not a sum"
+
+let val_array f o =
+  if Obj.is_block o then
+    for i = 0 to Obj.size o - 1 do
+      (f (Obj.field o i):unit)
+    done
+  else failwith "not array"
+(*
+let val_tuple s v o =
+  prerr_endline ("TUPLE "^s);
+  val_tuple s v o;
+  prerr_endline ("END "^s)
+let val_sum s cc vv o =
+  prerr_endline ("SUM "^s);
+  val_sum s cc vv o;
+  prerr_endline ("END "^s)
+let val_array f o =
+  prerr_endline "ARRAY";
+  val_array f o;
+  prerr_endline "END ARRAY"
+*)
+let val_int o = if not (Obj.is_int o) then failwith "not int"
+(*; prerr_endline "INT"
+*)
+let val_str s = val_tag Obj.string_tag s
+(*; prerr_endline ("STR "^Obj.magic s)*)
+
+let val_bool o = val_sum "bool" 2 [||] o
+
+let val_opt f = val_sum "option" 1 [|[|f|]|]
+
+let rec val_list f o =
+  val_sum "list" 1 [|[|f;val_list f|]|] o
+
+let val_ref f = val_tuple "ref" [|f|]
+
+let rec val_set f o =
+  val_sum "set" 1 [|[|val_set f;f;val_set f;val_int|]|] o
+let rec val_map fk fv o =
+  val_sum "map" 1 [|[|val_map fk fv;fk;fv;val_map fk fv;val_int|]|] o
+
+(* Coq *)
+
+let val_id = val_str
+
+let val_dp = val_list val_id
+
+let val_name = val_sum "name" 1 [|[|val_id|]|]
+
+let val_uid = val_tuple "uid" [|val_int;val_str;val_dp|]
+
+let rec val_mp o =
+  val_sum "mp" 0 [|[|val_dp|];[|val_uid|];[|val_uid|];[|val_mp;val_id|]|] o
+
+let val_kn = val_tuple "kn" [|val_mp;val_dp;val_id|]
+
+let val_ind = val_tuple "ind"[|val_kn;val_int|]
+let val_cstr = val_tuple "cstr"[|val_ind;val_int|]
+
+let val_ci = no_val
+
+let val_cast = no_val
+
+let val_level = val_sum "level" 1 [|[|val_dp;val_int|]|]
+let val_univ = val_sum "univ" 0
+  [|[|val_level|];[|val_list val_level;val_list val_level|]|]
+
+let val_cstrs =
+  val_set (val_tuple"univ_cstr"[|val_level;val_sum "order" 3[||];val_level|])
+
+let val_sort = val_sum "sort" 0 [|[|val_sum "cnt" 2 [||]|];[|val_univ|]|]
+let val_sortfam = val_sum "sort_family" 3 [||]
+
+let val_evar f = val_tuple "evar" [|val_int;val_array f|]
+
+let val_prec f =
+  val_tuple "prec"[|val_array val_name; val_array f; val_array f|]
+let val_fix f =
+  val_tuple"fix1"[|val_tuple"fix2"[|val_array val_int;val_int|];val_prec f|]
+let val_cofix f = val_tuple"cofix"[|val_int;val_prec f|]
+
+
+let rec val_constr o = val_sum "constr" 0 [|
+  [|val_int|]; (* Rel *)
+  [|val_id|]; (* Var *)
+  [|val_int|]; (* Meta *)
+  [|val_evar val_constr|]; (* Evar *)
+  [|val_sort|]; (* Sort *)
+  [|val_constr;val_cast;val_constr|]; (* Cast *)
+  [|val_name;val_constr;val_constr|]; (* Prod *)
+  [|val_name;val_constr;val_constr|]; (* Lambda *)
+  [|val_name;val_constr;val_constr;val_constr|]; (* LetIn *)
+  [|val_constr;val_array val_constr|]; (* App *)
+  [|val_kn|]; (* Const *)
+  [|val_ind|]; (* Ind *)
+  [|val_cstr|]; (* Construct *)
+  [|val_ci;val_constr;val_constr;val_array val_constr|]; (* Case *)
+  [|val_fix val_constr|]; (* Fix *)
+  [|val_cofix val_constr|] (* CoFix *)
+|] o
+
+
+let val_ndecl = val_tuple"ndecl"[|val_id;val_opt val_constr;val_constr|]
+let val_rdecl = val_tuple"rdecl"[|val_name;val_opt val_constr;val_constr|]
+let val_nctxt = val_list val_ndecl
+let val_rctxt = val_list val_rdecl
+
+let val_arity = val_tuple"arity"[|val_rctxt;val_constr|]
+
+let val_eng = val_sum "eng" 1 [||]
+
+let val_pol_arity = val_tuple"pol_arity"[|val_list(val_opt val_univ);val_univ|]
+let val_cst_type =
+  val_sum "cst_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|]
+
+let val_subst_dom =
+  val_sum "subst_dom" 0 [|[|val_uid|];[|val_uid|];[|val_mp|]|]
+
+
+let val_res = val_opt no_val
+
+let val_subst =
+  val_map val_subst_dom (val_tuple "subst range" [|val_mp;val_res|])
+
+let val_cstr_subst =
+  val_ref (val_sum "cstr_subst" 0 [|[|val_constr|];[|val_subst;val_constr|]|])
+
+let val_cb = val_tuple "cb"
+  [|val_nctxt;val_opt val_cstr_subst; val_cst_type;no_val;val_cstrs;
+    val_bool; val_bool |]
+
+let val_recarg = val_sum "recarg" 1 [|[|val_int|];[|val_ind|]|]
+
+let rec val_wfp o = val_sum "wf_paths" 0
+  [|[|val_int;val_int|];[|val_recarg;val_array val_wfp|];
+    [|val_int;val_array val_wfp|]|] o
+
+let val_mono_ind_arity = val_tuple"mono_ind_arity"[|val_constr;val_sort|]
+let val_ind_arity = val_sum "ind_arity" 0
+  [|[|val_mono_ind_arity|];[|val_pol_arity|]|]
+
+let val_one_ind = val_tuple "one_ind"
+  [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr;
+    val_int; val_list val_sortfam;val_array val_constr;val_array val_int;
+    val_wfp; val_int; val_int; no_val|]
+
+let val_ind_pack = val_tuple "ind_pack"
+  [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt;
+    val_int; val_int; val_rctxt;val_cstrs;val_opt val_kn|]
+
+let rec val_sfb o = val_sum "sfb" 0
+  [|[|val_cb|];[|val_ind_pack|];[|val_mod|];
+    [|val_mp;val_opt val_cstrs|];[|val_modty|]|] o
+and val_sb o = val_list (val_tuple"sb"[|val_id;val_sfb|]) o
+and val_seb o = val_sum "seb" 0
+  [|[|val_mp|];[|val_uid;val_modty;val_seb|];[|val_uid;val_sb|];
+    [|val_seb;val_seb;val_cstrs|];[|val_seb;val_with|]|] o
+and val_with o = val_sum "with" 0
+  [|[|val_list val_id;val_mp;val_cstrs|];
+    [|val_list val_id;val_cb|]|] o
+and val_mod o = val_tuple "module_body"
+  [|val_opt val_seb;val_opt val_seb;val_cstrs;val_subst;no_val|] o
+and val_modty o = val_tuple "module_type_body"
+  [|val_seb;val_opt val_mp;val_subst|] o
+
+let val_deps = val_list (val_tuple"dep"[|val_dp;no_val|])
+
+let val_vo = val_tuple "vo" [|val_dp;val_mod;val_deps;val_eng|]
diff --git a/kernel/univ.ml b/kernel/univ.ml
index dd00a5428..6e7fa4080 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -259,6 +259,55 @@ let compare g u v =
    Adding u>v is consistent iff compare(v,u) = NLE 
     and then it is redundant iff compare(u,v) = LT *)
 
+let compare_eq g u v =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  repr g u == repr g v
+
+
+type check_function = universes -> universe -> universe -> bool
+
+let incl_list cmp l1 l2 =
+  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 
+
+let compare_list cmp l1 l2 =
+  incl_list cmp l1 l2 && incl_list cmp l2 l1
+
+let rec check_eq g u v =
+  match (u,v) with
+    | Atom ul, Atom vl -> compare_eq g ul vl
+    | Max(ule,ult), Max(vle,vlt) ->
+        (* TODO: remove elements of lt in le! *)
+        compare_list (compare_eq g) ule vle &&
+        compare_list (compare_eq g) ult vlt
+    | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
+
+let check_eq g u v =
+  check_eq g u v
+
+let compare_greater g strict u v =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  if not strict && compare_eq g v Base then true else
+  match compare g v u with
+    | (EQ|LE) -> not strict
+    | LT -> true
+    | NLE -> false
+(*
+let compare_greater g strict u v =
+  let b = compare_greater g strict u v in
+  ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
+  b
+*)
+let rec check_greater g strict u v =
+  match u, v with
+    | Atom ul, Atom vl -> compare_greater g strict ul vl
+    | Atom ul, Max(le,lt) ->
+        List.for_all (fun vl -> compare_greater g strict ul vl) le &&
+        List.for_all (fun vl -> compare_greater g true ul vl) lt
+    | _ -> anomaly "check_greater"
+
+let check_geq g = check_greater g false
 
 (* setlt : universe_level -> universe_level -> unit *)
 (* forces u > v *)
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 52af808e3..c6f100dab 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -30,6 +30,10 @@ val sup   : universe -> universe -> universe
 
 type universes
 
+type check_function = universes -> universe -> universe -> bool
+val check_geq : check_function
+val check_eq : check_function
+
 (* The empty graph of universes *)
 val initial_universes : universes