Imported Upstream version 8.5~beta1+dfsg

39 files changed, 4629 insertions, 2517 deletions

diff --git a/checker/check.ml b/checker/check.ml
index 85ee28db..9a750858 100644
--- a/checker/check.ml
+++ b/checker/check.ml
@@ -1,31 +1,32 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
 
-let pr_dirpath dp = str (string_of_dirpath dp)
-let default_root_prefix = make_dirpath []
+let pr_dirpath dp = str (DirPath.to_string dp)
+let default_root_prefix = DirPath.empty
 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)
+  let l = DirPath.repr d in (DirPath.make (List.tl l), List.hd l)
+let extend_dirpath p id = DirPath.make (id :: DirPath.repr p)
 
 type section_path = {
   dirpath : string list ;
   basename : string }
 let dir_of_path p =
-  make_dirpath (List.map id_of_string p.dirpath)
+  DirPath.make (List.map Id.of_string p.dirpath)
 let path_of_dirpath dir =
-  match repr_dirpath dir with
+  match DirPath.repr dir with
       [] -> failwith "path_of_dirpath"
     | l::dir ->
-        {dirpath=List.map string_of_id dir;basename=string_of_id l}
+        {dirpath=List.map Id.to_string dir;basename=Id.to_string l}
 let pr_dirlist dp =
   prlist_with_sep (fun _ -> str".") str (List.rev dp)
 let pr_path sp =
@@ -33,37 +34,26 @@ let pr_path sp =
       [] -> 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.LightenLibrary.lightened_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 }
+  library_name : Cic.compilation_unit_name;
+  library_filename : CUnix.physical_path;
+  library_compiled : Cic.compiled_library;
+  library_opaques : Cic.opaque_table;
+  library_deps : Cic.library_deps;
+  library_digest : Cic.vodigest;
+  library_extra_univs : Univ.constraints }
 
 module LibraryOrdered =
   struct
-    type t = dir_path
+    type t = DirPath.t
     let compare d1 d2 =
       Pervasives.compare
-        (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
+        (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2))
   end
 
 module LibrarySet = Set.Make(LibraryOrdered)
@@ -80,7 +70,7 @@ let find_library dir =
 let try_find_library dir =
   try find_library dir
   with Not_found ->
-    error ("Unknown library " ^ (string_of_dirpath dir))
+    error ("Unknown library " ^ (DirPath.to_string dir))
 
 let library_full_filename dir = (find_library dir).library_filename
 
@@ -90,6 +80,29 @@ let library_full_filename dir = (find_library dir).library_filename
 let register_loaded_library m =
   libraries_table := LibraryMap.add m.library_name m !libraries_table
 
+(* Map from library names to table of opaque terms *)
+let opaque_tables = ref LibraryMap.empty
+let opaque_univ_tables = ref LibraryMap.empty
+
+let access_opaque_table dp i =
+  let t =
+    try LibraryMap.find dp !opaque_tables
+    with Not_found -> assert false
+  in
+  assert (i < Array.length t);
+  Future.force t.(i)
+
+let access_opaque_univ_table dp i =
+  try
+    let t = LibraryMap.find dp !opaque_univ_tables in
+    assert (i < Array.length t);
+    Future.force t.(i)
+  with Not_found -> Univ.empty_constraint
+
+
+let _ = Declarations.indirect_opaque_access := access_opaque_table
+let _ = Declarations.indirect_opaque_univ_access := access_opaque_univ_table
+
 let check_one_lib admit (dir,m) =
   let file = m.library_filename in
   let md = m.library_compiled in
@@ -98,22 +111,23 @@ let check_one_lib admit (dir,m) =
      also check if it carries a validation certificate (yet to
      be implemented). *)
   if LibrarySet.mem dir admit then
-    (Flags.if_verbose msgnl
+    (Flags.if_verbose ppnl
       (str "Admitting library: " ++ pr_dirpath dir);
-      Safe_typing.unsafe_import file md dig)
+      Safe_typing.unsafe_import file md m.library_extra_univs dig)
   else
-    (Flags.if_verbose msgnl
+    (Flags.if_verbose ppnl
       (str "Checking library: " ++ pr_dirpath dir);
-      Safe_typing.import file md dig);
-  Flags.if_verbose msg(fnl());
+      Safe_typing.import file md m.library_extra_univs dig);
+  Flags.if_verbose pp (fnl());
+  pp_flush ();
   register_loaded_library m
 
 (*************************************************************************)
 (*s Load path. Mapping from physical to logical paths etc.*)
 
-type logical_path = dir_path
+type logical_path = DirPath.t
 
-let load_paths = ref ([],[] : System.physical_path list * logical_path list)
+let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list)
 
 let get_load_paths () = fst !load_paths
 
@@ -147,20 +161,23 @@ let canonical_path_name 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
+  let physical, logical = !load_paths in
+  match List.filter2 (fun p d -> p = phys_dir) physical logical with
   | _,[dir] -> dir
   | _,[] -> default_root_prefix
-  | _,l -> anomaly ("Two logical paths are associated to "^phys_dir)
+  | _,l -> anomaly (Pp.str ("Two logical paths are associated to "^phys_dir))
 
 let remove_load_path dir =
-  load_paths := list_filter2 (fun p d -> p <> dir) !load_paths
+  let physical, logical = !load_paths in
+  load_paths := List.filter2 (fun p d -> p <> dir) physical logical
 
 let add_load_path (phys_path,coq_path) =
   if !Flags.debug then
-    msgnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++
+    ppnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++
            str phys_path);
   let phys_path = canonical_path_name phys_path in
-    match list_filter2 (fun p d -> p = phys_path) !load_paths with
+  let physical, logical = !load_paths in
+    match List.filter2 (fun p d -> p = phys_path) physical logical with
       | _,[dir] ->
 	  if coq_path <> dir
             (* If this is not the default -I . to coqtop *)
@@ -171,7 +188,7 @@ let add_load_path (phys_path,coq_path) =
 	    begin
               (* Assume the user is concerned by library naming *)
 	      if dir <> default_root_prefix then
-		Flags.if_warn msg_warning
+		msg_warning
 		  (str phys_path ++ strbrk " was previously bound to " ++
 		   pr_dirpath dir ++ strbrk "; it is remapped to " ++
 		   pr_dirpath coq_path);
@@ -180,10 +197,11 @@ let add_load_path (phys_path,coq_path) =
 	    end
       | _,[] ->
 	  load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths)
-      | _ -> anomaly ("Two logical paths are associated to "^phys_path)
+      | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path))
 
 let load_paths_of_dir_path dir =
-  fst (list_filter2 (fun p d -> d = dir) !load_paths)
+  let physical, logical = !load_paths in
+  fst (List.filter2 (fun p d -> d = dir) physical logical)
 
 (************************************************************************)
 (*s Locate absolute or partially qualified library names in the path *)
@@ -197,7 +215,7 @@ let locate_absolute_library dir =
   let loadpath = load_paths_of_dir_path pref in
   if loadpath = [] then raise LibUnmappedDir;
   try
-    let name = string_of_id base^".vo" in
+    let name = Id.to_string base^".vo" in
     let _, file = System.where_in_path ~warn:false loadpath name in
     (dir, file)
   with Not_found ->
@@ -220,7 +238,7 @@ let locate_qualified_library qid =
     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
+      extend_dirpath (find_logical_path path) (Id.of_string qid.basename) in
     (* Look if loaded *)
     try
       (dir, library_full_filename dir)
@@ -228,28 +246,29 @@ let locate_qualified_library qid =
       (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 error_unmapped_dir qid =
+  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 ())
+
+let error_lib_not_found qid =
+  errorlabstrm "load_absolute_library_from"
+    (str"Cannot find library " ++ pr_path qid ++ str" in loadpath")
 
 let try_locate_absolute_library dir =
   try
     locate_absolute_library dir
-  with e ->
-    explain_locate_library_error (path_of_dirpath dir) e
+  with
+    | LibUnmappedDir -> error_unmapped_dir (path_of_dirpath dir)
+    | LibNotFound -> error_lib_not_found (path_of_dirpath dir)
 
 let try_locate_qualified_library qid =
   try
     locate_qualified_library qid
-  with e ->
-    explain_locate_library_error qid e
+  with
+    | LibUnmappedDir -> error_unmapped_dir qid
+    | LibNotFound -> error_lib_not_found qid
 
 (************************************************************************)
 (*s Low-level interning/externing of libraries to files *)
@@ -257,7 +276,7 @@ let try_locate_qualified_library qid =
 (*s Loading from disk to cache (preparation phase) *)
 
 let raw_intern_library =
-  snd (System.raw_extern_intern Coq_config.vo_magic_number ".vo")
+  snd (System.raw_extern_intern Coq_config.vo_magic_number)
 
 let with_magic_number_check f a =
   try f a
@@ -270,12 +289,16 @@ let with_magic_number_check f a =
 (************************************************************************)
 (* Internalise libraries *)
 
-let mk_library md f table digest = {
+open Cic
+
+let mk_library md f table digest cst = {
   library_name = md.md_name;
   library_filename = f;
-  library_compiled = Safe_typing.LightenLibrary.load table md.md_compiled;
+  library_compiled = md.md_compiled;
+  library_opaques = table;
   library_deps = md.md_deps;
-  library_digest = digest }
+  library_digest = digest;
+  library_extra_univs = cst }
 
 let name_clash_message dir mdir f =
   str ("The file " ^ f ^ " contains library") ++ spc () ++
@@ -286,22 +309,56 @@ let name_clash_message dir mdir f =
 let depgraph = ref LibraryMap.empty
 
 let intern_from_file (dir, f) =
-  Flags.if_verbose msg (str"[intern "++str f++str" ...");
-  let (md,table,digest) =
+  Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush ();
+  let (md,table,opaque_csts,digest) =
     try
       let ch = with_magic_number_check raw_intern_library f in
-      let (md:library_disk) = System.marshal_in f ch in
-      let digest = System.marshal_in f ch in
-      let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in
-      close_in ch;
+      let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in
+      let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in
+      let (discharging:'a option), _, _ = System.marshal_in_segment f ch in
+      let (tasks:'a option), _, _ = System.marshal_in_segment f ch in
+      let (table:Cic.opaque_table), pos, checksum =
+        System.marshal_in_segment f ch in
+      (* Verification of the final checksum *)
+      let () = close_in ch in
+      let ch = open_in f in
+      if not (String.equal (Digest.channel ch pos) checksum) then
+        errorlabstrm "intern_from_file" (str "Checksum mismatch");
+      let () = close_in ch in
       if dir <> md.md_name then
-        errorlabstrm "load_physical_library"
+        errorlabstrm "intern_from_file"
           (name_clash_message dir md.md_name f);
-      Flags.if_verbose msgnl(str" done]");
-      md,table,digest
-    with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in
+      if tasks <> None || discharging <> None then
+        errorlabstrm "intern_from_file"
+          (str "The file "++str f++str " contains unfinished tasks");
+      if opaque_csts <> None then begin
+        pp (str " (was a vio file) ");
+      Option.iter (fun (_,_,b) -> if not b then
+        errorlabstrm "intern_from_file"
+          (str "The file "++str f++str " is still a .vio"))
+        opaque_csts;
+      Validate.validate !Flags.debug Values.v_univopaques opaque_csts;
+      end;
+      (* Verification of the unmarshalled values *)
+      Validate.validate !Flags.debug Values.v_lib md;
+      Validate.validate !Flags.debug Values.v_opaques table;
+      Flags.if_verbose ppnl (str" done]"); pp_flush ();
+      let digest =
+        if opaque_csts <> None then Cic.Dviovo (digest,udg)
+        else (Cic.Dvo digest) in
+      md,table,opaque_csts,digest
+    with e -> Flags.if_verbose ppnl (str" failed!]"); raise e in
   depgraph := LibraryMap.add md.md_name md.md_deps !depgraph;
-  mk_library md f table digest
+  opaque_tables := LibraryMap.add md.md_name table !opaque_tables;
+  Option.iter (fun (opaque_csts,_,_) ->
+    opaque_univ_tables :=
+      LibraryMap.add md.md_name opaque_csts !opaque_univ_tables)
+    opaque_csts;
+  let extra_cst =
+    Option.default Univ.empty_constraint
+      (Option.map (fun (_,cs,_) ->
+         Univ.ContextSet.constraints cs) opaque_csts) in
+  mk_library md f table digest extra_cst
 
 let get_deps (dir, f) =
   try LibraryMap.find dir !depgraph
@@ -317,14 +374,15 @@ let rec intern_library seen (dir, f) needed =
   try let _ = find_library dir in needed
   with Not_found ->
   (* Look if already listed and consequently its dependencies too *)
-  if List.mem_assoc dir needed then needed
+  if List.mem_assoc_f DirPath.equal dir needed then needed
   else
     (* [dir] is an absolute name which matches [f] which must be in loadpath *)
     let m = intern_from_file (dir,f) in
     let seen' = LibrarySet.add dir seen in
     let deps =
-      List.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps in
-    (dir,m) :: List.fold_right (intern_library seen') deps needed
+      Array.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps
+    in
+    (dir,m) :: Array.fold_right (intern_library seen') deps needed
 
 (* Compute the reflexive transitive dependency closure *)
 let rec fold_deps seen ff (dir,f) (s,acc) =
@@ -332,9 +390,9 @@ let rec fold_deps seen ff (dir,f) (s,acc) =
   if LibrarySet.mem dir s then (s,acc)
   else
     let deps = get_deps (dir,f) in
-    let deps = List.map (fun (d,_) -> try_locate_absolute_library d) deps in
+    let deps = Array.map (fun (d,_) -> try_locate_absolute_library d) deps in
     let seen' = LibrarySet.add dir seen in
-    let (s',acc') = List.fold_right (fold_deps seen' ff) deps (s,acc) in
+    let (s',acc') = Array.fold_right (fold_deps seen' ff) deps (s,acc) in
     (LibrarySet.add dir s', ff dir acc')
 
 and fold_deps_list seen ff modl needed =
@@ -358,14 +416,14 @@ let recheck_library ~norec ~admit ~check =
   let nochk =
     List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in
   (* *)
-  Flags.if_verbose msgnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++
+  Flags.if_verbose ppnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++
     prlist
     (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed));
   List.iter (check_one_lib nochk) needed;
-  Flags.if_verbose msgnl(str"Modules were successfully checked")
+  Flags.if_verbose ppnl (str"Modules were successfully checked")
 
 open Printf
 
 let mem s =
   let m = try_find_library s in
-  h 0 (str (sprintf "%dk" (size_kb m)))
+  h 0 (str (sprintf "%dk" (CObj.size_kb m)))
diff --git a/checker/check.mllib b/checker/check.mllib
index 08dd78bc..22df3756 100644
--- a/checker/check.mllib
+++ b/checker/check.mllib
@@ -1,22 +1,49 @@
 Coq_config
+
+Hook
+Canary
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+Flags
+Control
 Pp_control
+Loc
+Serialize
+Stateid
+Feedback
 Pp
-Compat
-Flags
 Segmenttree
 Unicodetable
+Unicode
+Errors
+CObj
+CList
+CString
+CArray
+CStack
 Util
-Option
-Hashcons
+Ephemeron
+Future
+CUnix
 System
+Profile
+RemoteCounter
 Envars
 Predicate
 Rtree
 Names
 Univ
 Esubst
-Validate
 Term
+Print
 Declarations
 Environ
 Closure
@@ -29,6 +56,8 @@ Indtypes
 Subtyping
 Mod_checking
 Safe_typing
+Values
+Validate
 Check
 Check_stat
 Checker
diff --git a/checker/check_stat.ml b/checker/check_stat.ml
index 145c191c..05a2a1b9 100644
--- a/checker/check_stat.ml
+++ b/checker/check_stat.ml
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \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 Cic
 open Declarations
 open Environ
 
@@ -19,7 +16,7 @@ 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.printf "total heap size = %d kbytes\n" (CObj.heap_size_kb ());
     Format.print_newline();
     flush_all()
   end
@@ -54,12 +51,12 @@ let print_context env =
          env_modules=mods; env_modtypes=mtys};
        env_stratification=
         {env_universes=univ; env_engagement=engt}} = env in
-    msgnl(hov 0
+    ppnl(hov 0
       (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++
       str"===============" ++ fnl() ++ fnl() ++
       str "* " ++ hov 0 (pr_engt engt ++ fnl()) ++ fnl() ++
       str "* " ++ hov 0 (pr_ax csts) ++
-      fnl()))
+      fnl())); pp_flush()
   end
 
 let stats () =
diff --git a/checker/check_stat.mli b/checker/check_stat.mli
index 5f9b801f..10908f0c 100644
--- a/checker/check_stat.mli
+++ b/checker/check_stat.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/checker/checker.ml b/checker/checker.ml
index 4afc02f9..ffe15531 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -1,21 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Compat
 open Pp
+open Errors
 open Util
 open System
 open Flags
 open Names
-open Term
 open Check
 
-let coq_root = id_of_string "Coq"
+let () = at_exit flush_all
+
+let fatal_error info anomaly =
+  flush_all (); pperrnl info; flush_all ();
+  exit (if anomaly then 129 else 1)
+
+let coq_root = Id.of_string "Coq"
 let parse_dir s =
   let len = String.length s in
   let rec decoupe_dirs dirs n =
@@ -32,27 +37,27 @@ let parse_dir s =
 let dirpath_of_string s =
   match parse_dir s with
       [] -> Check.default_root_prefix
-    | dir -> make_dirpath (List.map id_of_string dir)
+    | dir -> DirPath.make (List.map Id.of_string dir)
 let path_of_string s =
   match parse_dir s with
       [] -> invalid_arg "path_of_string"
     | l::dir -> {dirpath=dir; basename=l}
 
-let (/) = Filename.concat
+let ( / ) = Filename.concat
 
 let get_version_date () =
   try
-    let coqlib = Envars.coqlib () in
-    let ch = open_in (Filename.concat coqlib "revision") in
+    let ch = open_in (Envars.coqlib () / "revision") in
     let ver = input_line ch in
     let rev = input_line ch in
-      (ver,rev)
+    let () = close_in 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 Chicken %s (%s)\n" ver rev;
-    flush stdout
+  Printf.printf "Welcome to Chicken %s (%s)\n" ver rev;
+  flush stdout
 
 (* Adding files to Coq loadpath *)
 
@@ -65,20 +70,23 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
     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"
+  try Id.of_string d
+  with Errors.UserError _ ->
+    if_verbose msg_warning
+      (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)"));
+    raise Exit
 
 let add_rec_path ~unix_path ~coq_root =
   if exists_dir unix_path then
     let dirs = all_subdirs ~unix_path in
-    let prefix = repr_dirpath coq_root in
-    let convert_dirs (lp,cp) =
-      (lp,make_dirpath (List.map convert_string (List.rev cp)@prefix)) in
-    let dirs = map_succeed convert_dirs dirs in
+    let prefix = DirPath.repr coq_root in
+    let convert_dirs (lp, cp) =
+      try
+        let path = List.rev_map convert_string cp @ prefix in
+        Some (lp, Names.DirPath.make path)
+      with Exit -> None
+    in
+    let dirs = List.map_filter convert_dirs dirs in
     List.iter Check.add_load_path dirs;
     Check.add_load_path (unix_path, coq_root)
   else
@@ -107,14 +115,15 @@ let init_load_path () =
   let plugins = coqlib/"plugins" in
   (* NOTE: These directories are searched from last to first *)
   (* first standard library *)
-  add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.make_dirpath[coq_root]);
+  add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.DirPath.make[coq_root]);
   (* then plugins *)
-  add_rec_path ~unix_path:plugins ~coq_root:(Names.make_dirpath [coq_root]);
+  add_rec_path ~unix_path:plugins ~coq_root:(Names.DirPath.make [coq_root]);
   (* then user-contrib *)
   if Sys.file_exists user_contrib then
     add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix;
   (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
-  List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) xdg_dirs;
+  List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix)
+    (xdg_dirs ~warn:(fun x -> msg_warning (str x)));
   (* then directories in COQPATH *)
   List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath;
   (* then current directory *)
@@ -208,10 +217,10 @@ let anomaly_string () = str "Anomaly: "
 let report () = (str "." ++ spc () ++ str "Please report.")
 
 let print_loc loc =
-  if loc = dummy_loc then
+  if loc = Loc.ghost then
     (str"<unknown>")
   else
-    let loc = unloc loc in
+    let loc = Loc.unloc loc in
     (int (fst loc) ++ str"-" ++ int (snd loc))
 let guill s = "\""^s^"\""
 
@@ -223,8 +232,6 @@ let rec explain_exn = function
       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) ->
@@ -233,8 +240,6 @@ let rec explain_exn = function
       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) ++ str " at line " ++ int pos1 ++
@@ -250,26 +255,57 @@ let rec explain_exn = function
   | Univ.UniverseInconsistency (o,u,v) ->
       let msg =
 	if !Flags.debug (*!Constrextern.print_universes*) then
-	  spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++
+	  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")"
+	  ++ 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")
+      hov 0 (str "Type error: " ++
+      (match te with
+      | UnboundRel i -> str"UnboundRel " ++ int i
+      | UnboundVar v -> str"UnboundVar" ++ str(Names.Id.to_string v)
+      | NotAType _ -> str"NotAType"
+      | BadAssumption _ -> str"BadAssumption"
+      | ReferenceVariables _ -> str"ReferenceVariables"
+      | ElimArity _ -> str"ElimArity"
+      | CaseNotInductive _ -> str"CaseNotInductive"
+      | WrongCaseInfo _ -> str"WrongCaseInfo"
+      | NumberBranches _ -> str"NumberBranches"
+      | IllFormedBranch _ -> str"IllFormedBranch"
+      | Generalization _ -> str"Generalization"
+      | ActualType _ -> str"ActualType"
+      | CantApplyBadType ((n,a,b),(hd,hdty),args) ->
+          Format.printf "====== ill-typed term ====@\n";
+          Format.printf "@[<hov 2>application head=@ ";
+          Print.print_pure_constr hd;
+          Format.printf "@]@\n@[<hov 2>head type=@ ";
+          Print.print_pure_constr hdty;
+          Format.printf "@]@\narguments:@\n@[<hv>";
+          Array.iteri (fun i (t,ty) ->
+            Format.printf "@[<hov 2>arg %d=@ " (i+1);
+            Print.print_pure_constr t;
+            Format.printf "@ type=@ ";
+            Print.print_pure_constr ty) args;
+          Format.printf "@]@\n====== type error ====@\n";
+          Print.print_pure_constr b;
+          Format.printf "@\nis not convertible with@\n";
+          Print.print_pure_constr a;
+          Format.printf "@\n====== universes ====@\n";
+          Pp.pp (Univ.pr_universes
+            (ctx.Environ.env_stratification.Environ.env_universes));
+          str("\nCantApplyBadType at argument " ^ string_of_int n)
+      | CantApplyNonFunctional _ -> str"CantApplyNonFunctional"
+      | IllFormedRecBody _ -> str"IllFormedRecBody"
+      | IllTypedRecBody _ -> str"IllTypedRecBody"
+      | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints"))
 
   | 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)*)
-  | Loc.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 mt ()
@@ -278,19 +314,17 @@ let rec explain_exn = function
 		   str ", characters " ++ int e ++ str "-" ++
 		   int (e+6) ++ str ")")) ++
 	       report ())
-  | reraise ->
-      hov 0 (anomaly_string () ++ str "Uncaught exception " ++
-	       str (Printexc.to_string reraise)++report())
+  | e -> Errors.print e (* for anomalies and other uncaught exceptions *)
 
 let parse_args argv =
   let rec parse = function
     | [] -> ()
     | "-impredicative-set" :: rem ->
-      set_engagement Declarations.ImpredicativeSet; parse rem
+      set_engagement Cic.ImpredicativeSet; parse rem
 
     | "-coqlib" :: s :: rem ->
       if not (exists_dir s) then 
-	(msgnl (str ("Directory '"^s^"' does not exist")); exit 1);
+	fatal_error (str ("Directory '"^s^"' does not exist")) false;
       Flags.coqlib := s;
       Flags.coqlib_spec := true;
       parse rem
@@ -308,7 +342,9 @@ let parse_args argv =
     | "-debug" :: rem -> set_debug (); parse rem
 
     | "-where" :: _ ->
-        print_endline (Envars.coqlib ()); exit 0
+        Envars.set_coqlib ~fail:Errors.error;
+        print_endline (Envars.coqlib ());
+        exit 0
 
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
 
@@ -318,8 +354,6 @@ let parse_args argv =
     | ("-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 ()
 
@@ -330,19 +364,10 @@ let parse_args argv =
         Flags.make_silent true; parse rem
 
     | s :: _ when s<>"" && s.[0]='-' ->
-        msgnl (str "Unknown option " ++ str s); exit 1
+        fatal_error (str "Unknown option " ++ str s) false
     | s :: rem ->  add_compile s; parse rem
   in
-  try
-    parse (List.tl (Array.to_list 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
+  parse (List.tl (Array.to_list argv))
 
 
 (* To prevent from doing the initialization twice *)
@@ -354,14 +379,13 @@ let init_with_argv argv =
     Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
     try
       parse_args argv;
+      if !Flags.debug then Printexc.record_backtrace true;
+      Envars.set_coqlib ~fail:Errors.error;
       if_verbose print_header ();
       init_load_path ();
       engage ();
     with e ->
-      flush_all();
-      message "Error during initialization :";
-      msgnl (explain_exn e);
-      exit 1
+      fatal_error (str "Error during initialization :" ++ (explain_exn e)) (is_anomaly e)
   end
 
 let init() = init_with_argv Sys.argv
@@ -371,9 +395,7 @@ let run () =
     compile_files ();
     flush_all()
   with e ->
-    (flush_all();
-    Pp.ppnl(explain_exn e);
-    flush_all();
-    exit 1)
+    if !Flags.debug then Printexc.print_backtrace stderr;
+    fatal_error (explain_exn e) (is_anomaly e)
 
 let start () = init(); run(); Check_stat.stats(); exit 0
diff --git a/checker/cic.mli b/checker/cic.mli
new file mode 100644
index 00000000..a793fefa
--- /dev/null
+++ b/checker/cic.mli
@@ -0,0 +1,444 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Type definitions for the Calculus of Inductive Constructions *)
+
+(** We regroup here the type definitions for structures of the Coq kernel
+    that are present in .vo files. Here is everything the Checker needs
+    to know about these structures for verifying a .vo. Note that this
+    isn't an exact copy of the kernel code :
+
+    - there isn't any abstraction here (see e.g. [constr] or [lazy_constr])
+    - some types are left undefined when they aren't used by the Checker
+    - some types have less constructors when the final constructors aren't
+      supposed to appear in .vo (see [REVERTcast] and [Direct]).
+
+    The following types are also described in a reified manner in values.ml,
+    for validating the layout of structures after de-marshalling. So:
+
+    IF YOU ADAPT THIS FILE, YOU SHOULD MODIFY values.ml ACCORDINGLY !
+*)
+
+open Names
+
+(*************************************************************************)
+(** {4 From term.ml} *)
+
+(** {6 The sorts of CCI. } *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents       (** Prop and Set *)
+  | Type of Univ.universe  (** Type *)
+
+(** {6 The sorts family of CCI. } *)
+
+type sorts_family = InProp | InSet | InType
+
+(** {6 Useful types } *)
+
+(** {6 Existential variables } *)
+type existential_key = int
+
+(** {6 Existential variables } *)
+type metavariable = int
+
+(** {6 Case annotation } *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle
+  | RegularStyle (** infer printing form from number of constructor *)
+type case_printing =
+  { ind_tags : bool list; (* tell whether letin or lambda in the arity of the inductive type *)
+    cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *)
+    style     : case_style }
+
+(** the integer is the number of real args, needed for reduction *)
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*)
+    ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *)
+    ci_pp_info    : case_printing (** not interpreted by the kernel *)
+  }
+
+(** This defines the strategy to use for verifiying a Cast. *)
+type cast_kind = VMcast | NATIVEcast | DEFAULTcast (* | REVERTcast *)
+
+(** {6 The type of constructions } *)
+
+(** [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.t array * 'constr array * 'constr array
+type 'constr pfixpoint =
+    (int array * int) * 'constr prec_declaration
+type 'constr pcofixpoint =
+    int * 'constr prec_declaration
+type 'a puniverses = 'a Univ.puniverses
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+type constr =
+  | Rel       of int
+  | Var       of Id.t (** Shouldn't occur in a .vo *)
+  | Meta      of metavariable (** Shouldn't occur in a .vo *)
+  | Evar      of constr pexistential (** Shouldn't occur in a .vo *)
+  | Sort      of sorts
+  | Cast      of constr * cast_kind * constr
+  | Prod      of Name.t * constr * constr
+  | Lambda    of Name.t * constr * constr
+  | LetIn     of Name.t * constr * constr * constr
+  | App       of constr * constr array
+  | Const     of pconstant
+  | Ind       of pinductive
+  | Construct of pconstructor
+  | Case      of case_info * constr * constr * constr array
+  | Fix       of constr pfixpoint
+  | CoFix     of constr pcofixpoint
+  | Proj      of constant * constr
+
+type existential = constr pexistential
+type rec_declaration = constr prec_declaration
+type fixpoint = constr pfixpoint
+type cofixpoint = constr pcofixpoint
+
+(** {6 Type of assumptions and contexts}  *)
+
+type rel_declaration = Name.t * constr option * constr
+type rel_context = rel_declaration list
+
+(** The declarations below in .vo should be outside sections,
+    so we expect there a value compatible with an empty list *)
+type section_context = unit
+
+
+(*************************************************************************)
+(** {4 From mod_susbt.ml and lazyconstr.ml} *)
+
+(** {6 Substitutions} *)
+
+type delta_hint =
+  | Inline of int * constr option
+  | Equiv of kernel_name
+
+type delta_resolver = module_path MPmap.t * delta_hint KNmap.t
+
+type 'a umap_t = 'a MPmap.t * 'a MBImap.t
+type substitution = (module_path * delta_resolver) umap_t
+
+(** {6 Delayed constr} *)
+
+type 'a substituted = {
+  mutable subst_value : 'a;
+  mutable subst_subst : substitution list;
+}
+
+type constr_substituted = constr substituted
+
+(** Nota : in coqtop, the [lazy_constr] type also have a [Direct]
+    constructor, but it shouldn't occur inside a .vo, so we ignore it *)
+
+type lazy_constr =
+  | Indirect of substitution list * DirPath.t * int
+(* | Direct of constr_substituted *)
+
+
+(*************************************************************************)
+(** {4 From declarations.mli} *)
+
+(** Some types unused in the checker, hence left undefined *)
+
+(** Bytecode *)
+type reloc_table
+type to_patch_substituted
+(** Native code *)
+type native_name
+(** Retroknowledge *)
+type action
+
+(** Engagements *)
+
+type engagement = ImpredicativeSet
+
+(** {6 Representation of constants (Definition/Axiom) } *)
+
+
+type template_arity = {
+  template_param_levels : Univ.universe_level option list;
+  template_level : Univ.universe;
+}
+
+type ('a, 'b) declaration_arity = 
+  | RegularArity of 'a
+  | TemplateArity of 'b
+
+type constant_type = (constr, rel_context * template_arity) declaration_arity
+
+(** Inlining level of parameters at functor applications.
+    This is ignored by the checker. *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+(** Projections are a particular kind of constant: 
+    always transparent. *)
+
+type projection_body = {
+  proj_ind : mutual_inductive;
+  proj_npars : int;
+  proj_arg : int;
+  proj_type : constr; (* Type under params *)
+  proj_eta : constr * constr; (* Eta-expanded term and type *)
+  proj_body : constr; (* For compatibility, the match version *)
+}
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
+type constant_universes = Univ.universe_context
+
+type constant_body = {
+    const_hyps : section_context; (** New: younger hyp at top *)
+    const_body : constant_def;
+    const_type : constant_type;
+    const_body_code : to_patch_substituted;
+    const_polymorphic : bool; (** Is it polymorphic or not *)
+    const_universes : constant_universes;
+    const_proj : projection_body option;
+    const_inline_code : bool }
+
+(** {6 Representation of mutual inductive types } *)
+
+type recarg =
+  | Norec
+  | Mrec of inductive
+  | Imbr of inductive
+
+type wf_paths = recarg Rtree.t
+
+type record_body = (Id.t * constant array * projection_body array) option
+    (* The body is empty for non-primitive records, otherwise we get its
+       binder name in projections and list of projections if it is primitive. *)
+
+type regular_inductive_arity = {
+  mind_user_arity : constr;
+  mind_sort : sorts;
+}
+
+type recursivity_kind =
+  | Finite (** = inductive *)
+  | CoFinite (** = coinductive *)
+  | BiFinite (** = non-recursive, like in "Record" definitions *)
+
+type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity
+
+type one_inductive_body = {
+(** {8 Primitive datas } *)
+
+    mind_typename : Id.t; (** Name of the type: [Ii] *)
+
+    mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
+
+    mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *)
+
+    mind_consnames : Id.t array; (** Names of the constructors: [cij] *)
+
+    mind_user_lc : constr 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 *)
+
+(** {8 Derived datas } *)
+
+    mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
+
+    mind_nrealdecls : int; (** Length of realargs context (with let, no params) *)
+
+    mind_kelim : sorts_family list; (** List of allowed elimination sorts *)
+
+    mind_nf_lc : constr array; (** Head normalized constructor types so that their conclusion is atomic *)
+
+    mind_consnrealargs : int array;
+ (** Length of the signature of the constructors (w/o let, w/o params)
+    (not used in the kernel) *)
+
+    mind_consnrealdecls : int array;
+ (** Length of the signature of the constructors (with let, w/o params)
+    (not used in the kernel) *)
+
+    mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *)
+
+(** {8 Datas for bytecode compilation } *)
+
+    mind_nb_constant : int; (** number of constant constructor *)
+
+    mind_nb_args : int; (** number of no constant constructor *)
+
+    mind_reloc_tbl : reloc_table;
+  }
+
+type mutual_inductive_body = {
+
+    mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
+
+    mind_record : record_body option; (** Whether the inductive type has been declared as a record. *)
+
+    mind_finite : recursivity_kind;  (** Whether the type is inductive or coinductive *)
+
+    mind_ntypes : int;  (** Number of types in the block *)
+
+    mind_hyps : section_context;  (** Section hypotheses on which the block depends *)
+
+    mind_nparams : int;  (** Number of expected parameters *)
+
+    mind_nparams_rec : int;  (** Number of recursively uniform (i.e. ordinary) parameters *)
+
+    mind_params_ctxt : rel_context;  (** The context of parameters (includes let-in declaration) *)
+
+    mind_polymorphic : bool; (** Is it polymorphic or not *)
+
+    mind_universes : Univ.universe_context; (** Local universe variables and constraints *)
+
+    mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *)
+
+(** {8 Data for native compilation } *)
+
+    mind_native_name : native_name ref; (** status of the code (linked or not, and where) *)
+  }
+
+(** {6 Module declarations } *)
+
+(** Functor expressions are forced to be on top of other expressions *)
+
+type ('ty,'a) functorize =
+  | NoFunctor of 'a
+  | MoreFunctor of MBId.t * 'ty * ('ty,'a) functorize
+
+(** The fully-algebraic module expressions : names, applications, 'with ...'.
+    They correspond to the user entries of non-interactive modules.
+    They will be later expanded into module structures in [Mod_typing],
+    and won't play any role into the kernel after that : they are kept
+    only for short module printing and for extraction. *)
+
+type with_declaration =
+  | WithMod of Id.t list * module_path
+  | WithDef of Id.t list * constr
+
+type module_alg_expr =
+  | MEident of module_path
+  | MEapply of module_alg_expr * module_path
+  | MEwith of module_alg_expr * with_declaration
+
+(** A component of a module structure *)
+
+type structure_field_body =
+  | SFBconst of constant_body
+  | SFBmind of mutual_inductive_body
+  | SFBmodule of module_body
+  | SFBmodtype of module_type_body
+
+(** A module structure is a list of labeled components.
+
+    Note : we may encounter now (at most) twice the same label in
+    a [structure_body], once for a module ([SFBmodule] or [SFBmodtype])
+    and once for an object ([SFBconst] or [SFBmind]) *)
+
+and structure_body = (Label.t * structure_field_body) list
+
+(** A module signature is a structure, with possibly functors on top of it *)
+
+and module_signature = (module_type_body,structure_body) functorize
+
+(** A module expression is an algebraic expression, possibly functorized. *)
+
+and module_expression = (module_type_body,module_alg_expr) functorize
+
+and module_implementation =
+  | Abstract (** no accessible implementation (keep this constructor first!) *)
+  | Algebraic of module_expression (** non-interactive algebraic expression *)
+  | Struct of module_signature (** interactive body *)
+  | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *)
+
+and module_body =
+  { mod_mp : module_path; (** absolute path of the module *)
+    mod_expr : module_implementation; (** implementation *)
+    mod_type : module_signature; (** expanded type *)
+    (** algebraic type, kept if it's relevant for extraction *)
+    mod_type_alg : module_expression option;
+    (** set of all constraints in the module  *)
+    mod_constraints : Univ.constraints;
+    (** quotiented set of equivalent constants and inductive names *)
+    mod_delta : delta_resolver;
+    mod_retroknowledge : action list }
+
+(** A [module_type_body] is just a [module_body] with no
+    implementation ([mod_expr] always [Abstract]) and also
+    an empty [mod_retroknowledge] *)
+
+and module_type_body = module_body
+
+(*************************************************************************)
+(** {4 From safe_typing.ml} *)
+
+type nativecode_symb_array
+
+type compilation_unit_name = DirPath.t
+
+type vodigest =
+  | Dvo of Digest.t              (* The digest of the seg_lib part *)
+  | Dviovo of Digest.t * Digest.t (* The digest of the seg_lib+seg_univ part *)
+
+type library_info = compilation_unit_name * vodigest
+
+type library_deps = library_info array
+
+type compiled_library = {
+  comp_name : compilation_unit_name;
+  comp_mod : module_body;
+  comp_deps : library_deps;
+  comp_enga : engagement option;
+  comp_natsymbs : nativecode_symb_array
+}
+
+
+(*************************************************************************)
+(** {4 From library.ml} *)
+
+type library_objects
+
+type library_disk = {
+  md_name : compilation_unit_name;
+  md_compiled : compiled_library;
+  md_objects : library_objects;
+  md_deps : library_deps;
+  md_imports : compilation_unit_name array }
+
+type opaque_table = constr Future.computation array
+type univ_table =
+  (Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool) option
+
+(** A .vo file is currently made of :
+
+    1) a magic number (4 bytes, cf output_binary_int)
+    2) a marshalled [library_disk] structure
+    3) a [Digest.t] string (16 bytes)
+    4) a marshalled [univ_table] (* Some if vo was obtained from vi *)
+    5) a [Digest.t] string (16 bytes)
+    6) a marshalled [None] discharge_table (* Some in vi files *)
+    7) a [Digest.t] string (16 bytes)
+    8) a marshalled [None] todo_table (* Some in vi files *)
+    9) a [Digest.t] string (16 bytes)
+   10) a marshalled [opaque_table]
+   11) a [Digest.t] string (16 bytes)
+*)
diff --git a/checker/closure.ml b/checker/closure.ml
index 7a44eafb..356b683f 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,9 @@
 
 open Util
 open Pp
-open Term
 open Names
+open Cic
+open Term
 open Esubst
 open Environ
 
@@ -28,7 +29,7 @@ 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 ++
+  msg_debug (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"]")
 
@@ -48,11 +49,11 @@ let with_stats c =
   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)
+type transparent_state = Id.Pred.t * Cpred.t
+let all_opaque = (Id.Pred.empty, Cpred.empty)
+let all_transparent = (Id.Pred.full, Cpred.full)
 
-let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_variable (ids, _) id = Id.Pred.mem id ids
 let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
 
 module type RedFlagsSig = sig
@@ -63,7 +64,7 @@ module type RedFlagsSig = sig
   val fIOTA : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
-  val fVAR : identifier -> red_kind
+  val fVAR : Id.t -> red_kind
   val no_red : reds
   val red_add : reds -> red_kind -> reds
   val mkflags : red_kind list -> reds
@@ -85,7 +86,7 @@ module RedFlags = (struct
     r_iota : bool }
 
   type red_kind = BETA | DELTA | IOTA | ZETA
-	      | CONST of constant | VAR of identifier
+	      | CONST of constant | VAR of Id.t
   let fBETA = BETA
   let fDELTA = DELTA
   let fIOTA = IOTA
@@ -110,7 +111,7 @@ module RedFlags = (struct
     | ZETA -> { red with r_zeta = true }
     | VAR id ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = Idpred.add id l1, l2 }
+	{ red with r_const = Id.Pred.add id l1, l2 }
 
   let mkflags = List.fold_left red_add no_red
 
@@ -122,7 +123,7 @@ module RedFlags = (struct
 	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
+	let c = Id.Pred.mem id l in
 	incr_cnt c delta
     | ZETA -> incr_cnt red.r_zeta zeta
     | IOTA -> incr_cnt red.r_iota iota
@@ -150,7 +151,6 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
  *         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
@@ -160,49 +160,60 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
  * instantiations (cbv or lazy) are.
  *)
 
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
+type 'a tableKey =
+  | ConstKey of 'a
+  | VarKey of Id.t
   | RelKey of int
 
+type table_key = constant puniverses tableKey
+
+module KeyHash =
+struct
+  type t = table_key
+  let equal k1 k2 = match k1, k2 with
+  | ConstKey (c1,u1), ConstKey (c2,u2) -> Constant.UserOrd.equal c1 c2 
+    && Univ.Instance.equal u1 u2
+  | VarKey id1, VarKey id2 -> Id.equal id1 id2
+  | RelKey i1, RelKey i2 -> Int.equal i1 i2
+  | (ConstKey _ | VarKey _ | RelKey _), _ -> false
+
+  open Hashset.Combine
+
+  let hash = function
+  | ConstKey (c,u) -> combinesmall 1 (Constant.UserOrd.hash c)
+  | VarKey id -> combinesmall 2 (Id.hash id)
+  | RelKey i -> combinesmall 3 (Int.hash i)
+end
+
+module KeyTable = Hashtbl.Make(KeyHash)
+
 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 }
+  i_tab : 'a KeyTable.t }
 
 let ref_value_cache info ref =
   try
-    Some (Hashtbl.find info.i_tab ref)
+    Some (KeyTable.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
+	    let (s,l) = info.i_rels in lift n (Int.List.assoc (s-n) l)
+	| VarKey id -> raise Not_found
 	| ConstKey cst -> constant_value info.i_env cst
     in
     let v = info.i_repr info body in
-    Hashtbl.add info.i_tab ref v;
+    KeyTable.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
@@ -215,18 +226,14 @@ let defined_rels flags env =
 
 let mind_equiv_infos info = mind_equiv info.i_env
 
-let eq_table_key k1 k2 = 
- match k1,k2 with
-   | ConstKey con1 ,ConstKey con2 -> eq_con_chk con1 con2
-   | _,_  -> k1=k2
+let eq_table_key = KeyHash.equal
 
 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 }
+    i_tab = KeyTable.create 17 }
 
 
 (**********************************************************************)
@@ -266,16 +273,18 @@ and fterm =
   | FAtom of constr (* Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
-  | FInd of inductive
-  | FConstruct of constructor
+  | FInd of pinductive
+  | FConstruct of pconstructor
   | FApp of fconstr * fconstr array
+  | FProj of constant * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FCase of case_info * fconstr * fconstr * fconstr array
+  | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *)
   | 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
+  | FEvar of existential_key * fconstr array (* why diff from kernel/closure? *)
   | FLIFT of int * fconstr
   | FCLOS of constr * fconstr subs
   | FLOCKED
@@ -298,6 +307,8 @@ let update v1 (no,t) =
 type stack_member =
   | Zapp of fconstr array
   | Zcase of case_info * fconstr * fconstr array
+  | ZcaseT of case_info * constr * constr array * fconstr subs
+  | Zproj of int * int * constant
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -357,81 +368,14 @@ let compact_stack head stk =
 
 (* Put an update mark in the stack, only if needed *)
 let zupdate m s =
-  if !share & m.norm = Red
+  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', subs_id 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)
 
@@ -452,7 +396,7 @@ let mk_clos e t =
     | 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 _) ->
+    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) ->
         {norm = Red; term = FCLOS(t,e)}
 
 let mk_clos_vect env v = Array.map (mk_clos env) v
@@ -471,10 +415,11 @@ let mk_clos_deep clos_fun env t =
     | App (f,v) ->
         { norm = Red;
 	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
+    | Proj (p,c) ->
+	{ norm = Red;
+	  term = FProj (p, clos_fun env c) }
     | Case (ci,p,c,v) ->
-        { norm = Red;
-	  term = FCases (ci, clos_fun env p, clos_fun env c,
-			 Array.map (clos_fun env) v) }
+        { norm = Red; term = FCaseT (ci, p, clos_fun env c, v, env) }
     | Fix fx ->
         { norm = Cstr; term = FFix (fx, env) }
     | CoFix cfx ->
@@ -505,10 +450,13 @@ let rec to_constr constr_fun lfts v =
     | FFlex (ConstKey op) -> Const op
     | FInd op -> Ind op
     | FConstruct op -> Construct op
-    | FCases (ci,p,c,ve) ->
+    | FCase (ci,p,c,ve) ->
 	Case (ci, constr_fun lfts p,
               constr_fun lfts c,
 	      Array.map (constr_fun lfts) ve)
+    | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *)
+        to_constr constr_fun lfts
+	  {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)}
     | FFix ((op,(lna,tys,bds)),e) ->
         let n = Array.length bds in
         let ftys = Array.map (mk_clos e) tys in
@@ -526,6 +474,8 @@ let rec to_constr constr_fun lfts v =
     | FApp (f,ve) ->
 	App (constr_fun lfts f,
 	       Array.map (constr_fun lfts) ve)
+    | FProj (p,c) ->
+        Proj (p,constr_fun lfts c)
     | FLambda _ ->
         let (na,ty,bd) = destFLambda mk_clos2 v in
 	Lambda (na, constr_fun lfts ty,
@@ -544,7 +494,7 @@ let rec to_constr constr_fun lfts v =
         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_")*)
+    | 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,
@@ -553,11 +503,13 @@ let rec to_constr constr_fun lfts v =
 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 ->
+      | 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
+      | FCaseT(ci,p,c,b,env) when is_subs_id env && is_lift_id lfts ->
+          Case(ci,p,term_of_fconstr_lift lfts c,b)
+      | 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 el_id
 
@@ -575,8 +527,13 @@ let rec zip m stk =
     | [] -> 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
+        let t = FCase(ci, p, m, br) in
+        zip {norm=neutr m.norm; term=t} s
+    | ZcaseT(ci,p,br,e)::s ->
+        let t = FCaseT(ci, p, m, br, e) in
         zip {norm=neutr m.norm; term=t} s
+    | Zproj (i,j,cst) :: s -> 
+        zip {norm=neutr m.norm; term=FProj (cst,m)} s
     | Zfix(fx,par)::s ->
         zip fx (par @ append_stack [|m|] s)
     | Zshift(n)::s ->
@@ -647,13 +604,14 @@ let rec get_args n tys f e stk =
           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
+          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)
 
 (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
 let rec eta_expand_stack = function
-  | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+  | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ 
+	| Zshift _ | Zupdate _ as e) :: s ->
       e :: eta_expand_stack s
   | [] ->
       [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
@@ -670,18 +628,69 @@ let rec reloc_rargs_rec depth 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
+let rec try_drop_parameters depth n argstk =
+  match argstk 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
+        if n > q then try_drop_parameters depth (n-q) s
+        else if Int.equal 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) *)
+    | Zshift(k)::s -> try_drop_parameters (depth-k) n s
+    | [] -> 
+	if Int.equal n 0 then []
+	else raise Not_found
+    | _ -> assert false
+	(* strip_update_shift_app only produces Zapp and Zshift items *)
+
+let drop_parameters depth n argstk =
+  try try_drop_parameters depth n argstk
+  with Not_found -> assert false
+    (* we know that n < stack_args_size(argstk) (if well-typed term) *) 
+
+(** Projections and eta expansion *)
+
+let rec get_parameters depth n argstk =
+  match argstk with
+      Zapp args::s ->
+        let q = Array.length args in
+        if n > q then Array.append args (get_parameters depth (n-q) s)
+        else if Int.equal n q then [||]
+        else Array.sub args 0 n
+    | Zshift(k)::s -> 
+      get_parameters (depth-k) n s
+    | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *)
+	if Int.equal n 0 then [||]
+	else raise Not_found (* Trying to eta-expand a partial application..., should do 
+				eta expansion first? *)
+    | _ -> assert false
+	(* strip_update_shift_app only produces Zapp and Zshift items *)
+
+let eta_expand_ind_stack env ind m s (f, s') =
+  let mib = lookup_mind (fst ind) env in
+    match mib.mind_record with
+    | Some (Some (_,projs,pbs)) when mib.mind_finite <> CoFinite -> 
+	(* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
+	   arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
+      let pars = mib.mind_nparams in
+      let right = fapp_stack (f, s') in
+      let (depth, args, s) = strip_update_shift_app m s in
+      (** Try to drop the params, might fail on partially applied constructors. *)
+      let argss = try_drop_parameters depth pars args in
+      let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *)
+					 term = FProj (p, right) }) projs in
+	argss, [Zapp hstack]	
+    | _ -> raise Not_found (* disallow eta-exp for non-primitive records *)
+
+let rec project_nth_arg n argstk =
+  match argstk with
+  | Zapp args :: s -> 
+      let q = Array.length args in
+	if n >= q then project_nth_arg (n - q) s
+	else (* n < q *) args.(n)
+  | _ -> assert false
+      (* After drop_parameters we have a purely applicative stack *)
 
 
 (* Iota reduction: expansion of a fixpoint.
@@ -714,33 +723,42 @@ let contract_fix_vect fix =
    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 =
+let rec knh info m stk =
   match m.term with
-    | FLIFT(k,a) -> knh a (zshift k stk)
-    | FCLOS(t,e) -> knht e t (zupdate m stk)
+    | FLIFT(k,a) -> knh info a (zshift k stk)
+    | FCLOS(t,e) -> knht info 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)
+    | FApp(a,b) -> knh info a (append_stack b (zupdate m stk))
+    | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk)
+    | FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::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')
+             (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk')
            | (None, stk') -> (m,stk'))
-    | FCast(t,_,_) -> knh t stk
+    | FCast(t,_,_) -> knh info t stk
+
+    | FProj (p,c) ->
+      if red_set info.i_flags (fCONST p) then
+        (let pb = lookup_projection p (info.i_env) in
+	   knh info c (Zproj (pb.proj_npars, pb.proj_arg, p)
+		       :: zupdate m stk))
+      else (m,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 =
+and knht info 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
+        knht info e a (append_stack (mk_clos_vect e b) stk)
+    | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk)
+    | Fix _ -> knh info (mk_clos2 e t) stk (* laziness *)
+    | Cast(a,_,_) -> knht info  e a stk
+    | Rel n -> knh info (clos_rel e n) stk
+    | Proj (p,c) -> knh info (mk_clos2 e t) stk (* laziness *)
     | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
        LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
         (mk_clos2 e t, stk)
@@ -755,7 +773,7 @@ let rec knr info m stk =
       (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) ->
+  | FFlex(ConstKey kn) when red_set info.i_flags (fCONST (fst kn)) ->
       (match ref_value_cache info (ConstKey kn) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
@@ -767,21 +785,29 @@ let rec knr info m stk =
       (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 ->
+  | FConstruct((ind,c),u) 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) ->
+       | (depth, args, ZcaseT(ci,_,br,env)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            knit info env 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))
+       | (depth, args, Zproj (n, m, cst)::s) ->
+	    let rargs = drop_parameters depth n args in
+	    let rarg = project_nth_arg m rargs in
+	    kni info rarg s
+       | (_,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')) ->
+          (_, args, (((Zcase _|ZcaseT _)::_) as stk')) ->
             let (fxe,fxbd) = contract_fix_vect m.term in
             knit info fxe fxbd (args@stk')
         | (_,args,s) -> (m,args@s))
@@ -791,10 +817,10 @@ let rec knr info m stk =
 
 (* Computes the weak head normal form of a term *)
 and kni info m stk =
-  let (hm,s) = knh m stk in
+  let (hm,s) = knh info m stk in
   knr info hm s
 and knit info e t stk =
-  let (ht,s) = knht e t stk in
+  let (ht,s) = knht info e t stk in
   knr info ht s
 
 let kh info v stk = fapp_stack(kni info v stk)
@@ -816,6 +842,9 @@ let whd_stack infos m stk =
 (* cache of constants: the body is computed only when needed. *)
 type clos_infos = fconstr infos
 
+let infos_env x = x.i_env
+let infos_flags x = x.i_flags
+
 let create_clos_infos flgs env =
   create (fun _ -> inject) flgs env
 
diff --git a/checker/closure.mli b/checker/closure.mli
index e072a106..e6b39250 100644
--- a/checker/closure.mli
+++ b/checker/closure.mli
@@ -1,15 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Pp
 open Names
-open Term
+open Cic
 open Esubst
 open Environ
 (*i*)
@@ -25,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a
   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
   a LetIn expression is Letin reduction *)
 
-type transparent_state = Idpred.t * Cpred.t
+type transparent_state = Id.Pred.t * Cpred.t
 
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
@@ -44,7 +43,7 @@ module type RedFlagsSig = sig
   val fIOTA : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
-  val fVAR : identifier -> red_kind
+  val fVAR : Id.t -> red_kind
 
   (* No reduction at all *)
   val no_red : reds
@@ -67,11 +66,13 @@ val betaiotazeta       : reds
 val betadeltaiotanolet : reds
 
 (***********************************************************************)
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
+type 'a tableKey =
+  | ConstKey of 'a
+  | VarKey of Id.t
   | RelKey of int
 
+type table_key = constant puniverses tableKey
+
 type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
 val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos
@@ -91,12 +92,14 @@ type fterm =
   | FAtom of constr (* Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
-  | FInd of inductive
-  | FConstruct of constructor
+  | FInd of pinductive
+  | FConstruct of pconstructor
   | FApp of fconstr * fconstr array
+  | FProj of constant * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FCase of case_info * fconstr * fconstr * fconstr array
+  | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *)
   | FLambda of int * (name * constr) list * constr * fconstr subs
   | FProd of name * fconstr * fconstr
   | FLetIn of name * fconstr * fconstr * constr * fconstr subs
@@ -113,6 +116,8 @@ type fterm =
 type stack_member =
   | Zapp of fconstr array
   | Zcase of case_info * fconstr * fconstr array
+  | ZcaseT of case_info * constr * constr array * fconstr subs
+  | Zproj of int * int * constant
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -121,6 +126,9 @@ and stack = stack_member list
 
 val append_stack : fconstr array -> stack -> stack
 val eta_expand_stack : stack -> stack
+ 
+val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> 
+   (fconstr * stack) -> stack * stack
 
 (* To lazy reduce a constr, create a [clos_infos] with
    [create_clos_infos], inject the term to reduce with [inject]; then use
@@ -136,6 +144,8 @@ val destFLambda :
 (* Global and local constant cache *)
 type clos_infos
 val create_clos_infos : reds -> env -> clos_infos
+val infos_env : clos_infos -> env
+val infos_flags : clos_infos -> reds
 
 (* Reduction function *)
 
@@ -172,6 +182,5 @@ 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
index 890996d1..c6709a78 100644
--- a/checker/declarations.ml
+++ b/checker/declarations.ml
@@ -1,44 +1,14 @@
 open Util
 open Names
+open Cic
 open Term
-open Validate
-
-(* Bytecode *)
-type values
-type reloc_table
-type to_patch_substituted
-(*Retroknowledge *)
-type action
-type retroknowledge
-
-type engagement = ImpredicativeSet
-let val_eng = val_enum "eng" 1
-
-
-type polymorphic_arity = {
-  poly_param_levels : Univ.universe option list;
-  poly_level : Univ.universe;
-}
-let val_pol_arity =
-  val_tuple ~name:"polyorphic_arity"[|val_list(val_opt val_univ);val_univ|]
-
-type constant_type =
-  | NonPolymorphicType of constr
-  | PolymorphicArity of rel_context * polymorphic_arity
-
-let val_cst_type =
-  val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|]
 
 (** Substitutions, code imported from kernel/mod_subst *)
 
-type delta_hint =
-  | Inline of int * constr option
-  | Equiv of kernel_name
-
-
 module Deltamap = struct
-  type t = module_path MPmap.t * delta_hint KNmap.t
+  type t = delta_resolver
   let empty = MPmap.empty, KNmap.empty
+  let is_empty (mm, km) = MPmap.is_empty mm && KNmap.is_empty km
   let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
   let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
   let remove_mp mp (mm,km) = (MPmap.remove mp mm, km)
@@ -52,18 +22,10 @@ module Deltamap = struct
   let join map1 map2 = fold add_mp add_kn map1 map2
 end
 
-type delta_resolver = Deltamap.t
-
 let empty_delta_resolver = Deltamap.empty
 
-module MBImap = Map.Make
-  (struct
-    type t = mod_bound_id
-    let compare = Pervasives.compare
-   end)
-
 module Umap = struct
-  type 'a t = 'a MPmap.t * 'a MBImap.t
+  type 'a t = 'a umap_t
   let empty = MPmap.empty, MBImap.empty
   let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2
   let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2)
@@ -78,29 +40,12 @@ module Umap = struct
   let join map1 map2 = fold add_mp add_mbi map1 map2
 end
 
-type substitution = (module_path * delta_resolver) Umap.t
 type 'a subst_fun = substitution -> 'a -> 'a
 
 let empty_subst = Umap.empty
 
 let is_empty_subst = Umap.is_empty
 
-let val_delta_hint =
-  val_sum "delta_hint" 0
-    [|[|val_int; val_opt val_constr|];[|val_kn|]|]
-
-let val_res =
-  val_tuple ~name:"delta_resolver"
-    [|val_map ~name:"delta_resolver" val_mp val_mp;
-      val_map ~name:"delta_resolver" val_kn val_delta_hint|]
-
-let val_mp_res = val_tuple [|val_mp;val_res|]
-
-let val_subst =
-  val_tuple ~name:"substitution"
-    [|val_map ~name:"substitution" val_mp val_mp_res;
-      val_map ~name:"substitution" val_uid val_mp_res|]
-
 let add_mbid mbid mp = Umap.add_mbi mbid (mp,empty_delta_resolver)
 let add_mp mp1 mp2 = Umap.add_mp mp1 (mp2,empty_delta_resolver)
 
@@ -110,7 +55,7 @@ let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst
 let mp_in_delta mp =
   Deltamap.mem_mp mp
 
-let rec find_prefix resolve mp =
+let find_prefix resolve mp =
   let rec sub_mp = function
     | MPdot(mp,l) as mp_sup ->
 	(try Deltamap.find_mp mp_sup resolve
@@ -136,10 +81,8 @@ let solve_delta_kn resolve kn =
       make_kn new_mp dir l
 
 let gen_of_delta resolve x kn fix_can =
-  try
-    let new_kn = solve_delta_kn resolve kn in
-    if kn == new_kn then x else fix_can new_kn
-  with _ -> x
+  let new_kn = solve_delta_kn resolve kn in
+  if kn == new_kn then x else fix_can new_kn
 
 let constant_of_delta resolve con =
   let kn = user_con con in
@@ -221,6 +164,11 @@ let gen_subst_mp f sub mp1 mp2 =
     | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
     | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
 
+let make_mind_equiv mpu mpc dir l =
+  let knu = make_kn mpu dir l in
+  if mpu == mpc then mind_of_kn knu
+  else mind_of_kn_equiv knu (make_kn mpc dir l)
+
 let subst_ind sub mind =
   let kn1,kn2 = user_mind mind, canonical_mind mind in
   let mp1,dir,l = repr_kn kn1 in
@@ -233,12 +181,17 @@ let subst_ind sub mind =
       | Canonical -> mind_of_delta2 resolve mind'
   with No_subst -> mind
 
-let subst_con0 sub con =
+let make_con_equiv mpu mpc dir l =
+  let knu = make_kn mpu dir l in
+  if mpu == mpc then constant_of_kn knu
+  else constant_of_kn_equiv knu (make_kn mpc dir l)
+
+let subst_con0 sub con u =
   let kn1,kn2 = user_con con,canonical_con con in
   let mp1,dir,l = repr_kn kn1 in
   let mp2,_,_ = repr_kn kn2 in
   let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
-  let dup con = con, Const con in
+  let dup con = con, Const (con, u) in
   let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
   match constant_of_delta_with_inline resolve con' with
     | Some t -> con', t
@@ -252,13 +205,21 @@ let subst_con0 sub con =
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match c with
-      | Const kn -> (try snd (f' kn) with No_subst -> c)
-      | Ind (kn,i) ->
+      | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c)
+      | Proj (kn,t) -> 
+          let kn' = 
+	    try fst (f' kn Univ.Instance.empty)
+	    with No_subst -> kn 
+	  in
+	  let t' = func t in
+	    if kn' == kn && t' == t then c
+	    else Proj (kn', t')
+      | Ind ((kn,i),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else Ind (kn',i)
-      | Construct ((kn,i),j) ->
+	  if kn'==kn then c else Ind ((kn',i),u)
+      | Construct (((kn,i),j),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else Construct ((kn',i),j)
+	  if kn'==kn then c else Construct (((kn',i),j),u)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
@@ -267,7 +228,7 @@ let rec map_kn f f' c =
 	  in
 	  let p' = func p in
 	  let ct' = func ct in
-	  let l' = array_smartmap func l in
+	  let l' = Array.smartmap func l in
 	    if (ci.ci_ind==ci_ind && p'==p
 		&& l'==l && ct'==ct)then c
 	    else
@@ -296,21 +257,21 @@ let rec map_kn f f' c =
 	    else LetIn (na, b', t', ct')
       | App (ct,l) ->
 	  let ct' = func ct in
-	  let l' = array_smartmap func l 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
+	  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
+	  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
+	  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
@@ -318,24 +279,10 @@ let rec map_kn f f' c =
 let subst_mps sub c =
   if is_empty_subst sub then c
   else map_kn (subst_ind sub) (subst_con0 sub) c
-
-
-type 'a lazy_subst =
-  | LSval of 'a
-  | LSlazy of substitution list * 'a
-
-type 'a substituted = 'a lazy_subst ref
-
-let val_substituted val_a =
-  val_ref
-    (val_sum "constr_substituted" 0
-      [|[|val_a|];[|val_list val_subst;val_a|]|])
-
-let from_val a = ref (LSval a)
  
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
-    | _ when mp = mpfrom -> mpto
+    | _ when ModPath.equal mp mpfrom -> mpto
     | MPdot (mp1,l) ->
 	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
 	  if mp1==mp1' then mp
@@ -344,7 +291,7 @@ let rec replace_mp_in_mp mpfrom mpto mp =
 
 let rec mp_in_mp mp mp1 =
   match mp1 with
-    | _ when mp1 = mp -> true
+    | _ when ModPath.equal mp1 mp -> true
     | MPdot (mp2,l) -> mp_in_mp mp mp2
     | _ -> false
 
@@ -417,14 +364,14 @@ let update_delta_resolver resolver1 resolver2 =
 let add_delta_resolver resolver1 resolver2 =
   if resolver1 == resolver2 then
     resolver2
-  else if resolver2 = empty_delta_resolver then
+  else if Deltamap.is_empty resolver2 then
     resolver1
   else
     Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2
 
 let substition_prefixed_by k mp subst =
   let mp_prefixmp kmp (mp_to,reso) sub =
-    if mp_in_mp mp kmp && mp <> kmp then
+    if mp_in_mp mp kmp && not (ModPath.equal mp kmp) then
       let new_key = replace_mp_in_mp mp k kmp in
       Umap.add_mp new_key (mp_to,reso) sub
     else sub
@@ -455,75 +402,51 @@ let join subst1 subst2 =
   let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in
   Umap.join subst2 subst
 
-let force fsubst r =
-  match !r with
-  | LSval a -> a
-  | LSlazy(s,a) ->
-      let subst = List.fold_left join empty_subst (List.rev s) in
-      let a' = fsubst subst a in
-      r := LSval a';
-      a'
-
-let subst_substituted s r =
-  match !r with
-    | LSval a -> ref (LSlazy([s],a))
-    | LSlazy(s',a) ->
-	  ref (LSlazy(s::s',a))
+let from_val x = { subst_value = x; subst_subst = []; }
 
-let force_constr = force subst_mps
+let force fsubst r = match r.subst_subst with
+| [] -> r.subst_value
+| s ->
+  let subst = List.fold_left join empty_subst (List.rev s) in
+  let x = fsubst subst r.subst_value in
+  let () = r.subst_subst <- [] in
+  let () = r.subst_value <- x in
+  x
 
-type constr_substituted = constr substituted
+let subst_substituted s r = { r with subst_subst = s :: r.subst_subst; }
 
-let val_cstr_subst = val_substituted val_constr
+let force_constr = force subst_mps
 
 let subst_constr_subst = subst_substituted
 
-(** Beware! In .vo files, lazy_constr are stored as integers
-   used as indexes for a separate table. The actual lazy_constr is restored
-   later, by [Safe_typing.LightenLibrary.load]. This allows us
-   to use here a different definition of lazy_constr than coqtop:
-   since the checker will inspect all proofs parts, even opaque
-   ones, no need to use Lazy.t here *)
-
-type lazy_constr = constr_substituted
-let subst_lazy_constr = subst_substituted
-let force_lazy_constr = force_constr
-let lazy_constr_from_val c = c
-let val_lazy_constr = val_cstr_subst
-
-(** Inlining level of parameters at functor applications.
-    This is ignored by the checker. *)
-
-type inline = int option
+let subst_lazy_constr sub = function
+  | Indirect (l,dp,i) -> Indirect (sub::l,dp,i)
 
-(** A constant can have no body (axiom/parameter), or a
-    transparent body, or an opaque one *)
+let indirect_opaque_access =
+  ref ((fun dp i -> assert false) : DirPath.t -> int -> constr)
+let indirect_opaque_univ_access =
+  ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.constraints)
 
-type constant_def =
-  | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
+let force_lazy_constr = function
+  | Indirect (l,dp,i) ->
+    let c = !indirect_opaque_access dp i in
+    force_constr (List.fold_right subst_constr_subst l (from_val c))
 
-let val_cst_def =
-  val_sum "constant_def" 0
-    [|[|val_opt val_int|]; [|val_cstr_subst|]; [|val_lazy_constr|]|]
+let force_lazy_constr_univs = function
+  | OpaqueDef (Indirect (l,dp,i)) -> !indirect_opaque_univ_access dp i
+  | _ -> Univ.empty_constraint
 
 let subst_constant_def sub = function
   | Undef inl -> Undef inl
   | Def c -> Def (subst_constr_subst sub c)
   | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
 
-type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constant_def;
-    const_type : constant_type;
-    const_body_code : to_patch_substituted;
-    const_constraints : Univ.constraints }
+(** Local variables and graph *)
 
 let body_of_constant cb = match cb.const_body with
   | Undef _ -> None
-  | Def c -> Some c
-  | OpaqueDef c -> Some c
+  | Def c -> Some (force_constr c)
+  | OpaqueDef c -> Some (force_lazy_constr c)
 
 let constant_has_body cb = match cb.const_body with
   | Undef _ -> false
@@ -533,40 +456,18 @@ let is_opaque cb = match cb.const_body with
   | OpaqueDef _ -> true
   | Def _ | Undef _ -> false
 
-let val_cb = val_tuple ~name:"constant_body"
-  [|val_nctxt;
-    val_cst_def;
-    val_cst_type;
-    no_val;
-    val_cstrs|]
-
 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)
+  if copt == copt' && t == t' then x else (id,copt',t')
 
-type recarg =
-  | Norec
-  | Mrec of inductive
-  | Imbr of inductive
-let val_recarg = val_sum "recarg" 1 (* Norec *)
-  [|[|val_ind|] (* Mrec *);[|val_ind|] (* Imbr *)|]
+let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
 
 let subst_recarg sub r = match r with
   | Norec  -> r
   | (Mrec(kn,i)|Imbr (kn,i)) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
-type wf_paths = recarg Rtree.t
-let val_wfp = val_rec_sum "wf_paths" 0
-  (fun val_wfp ->
-    [|[|val_int;val_int|]; (* Rtree.Param *)
-      [|val_recarg;val_array val_wfp|]; (* Rtree.Node *)
-      [|val_int;val_array val_wfp|] (* Rtree.Rec *)
-    |])
-
 let mk_norec = Rtree.mk_node Norec [||]
 
 let mk_paths r recargs =
@@ -581,6 +482,14 @@ let dest_subterms p =
 
 let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
 
+let eq_recarg r1 r2 = match r1, r2 with
+  | Norec, Norec -> true
+  | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2
+  | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2
+  | _ -> false
+
+let eq_wf_paths = Rtree.equal eq_recarg
+
 (**********************************************************************)
 (* Representation of mutual inductive types in the kernel             *)
 (*
@@ -589,142 +498,66 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
    with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
 *)
 
-type monomorphic_inductive_arity = {
-  mind_user_arity : constr;
-  mind_sort : sorts;
-}
-let val_mono_ind_arity =
-  val_tuple ~name:"monomorphic_inductive_arity"[|val_constr;val_sort|]
-
-type inductive_arity =
-| Monomorphic of monomorphic_inductive_arity
-| Polymorphic of polymorphic_arity
-let val_ind_arity = val_sum "inductive_arity" 0
-  [|[|val_mono_ind_arity|];[|val_pol_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;
+let subst_decl_arity f g sub ar = 
+  match ar with
+  | RegularArity x -> 
+    let x' = f sub x in 
+      if x' == x then ar
+      else RegularArity x'
+  | TemplateArity x -> 
+    let x' = g sub x in 
+      if x' == x then ar
+      else TemplateArity x'
 
- (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
-    mind_arity : inductive_arity;
+let map_decl_arity f g = function
+  | RegularArity a -> RegularArity (f a)
+  | TemplateArity a -> TemplateArity (g a)
 
- (* 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;
-
- (* Length of realargs context (with let, no params) *)
-    mind_nrealargs_ctxt : 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;
-  }
-
-let val_one_ind = val_tuple ~name:"one_inductive_body"
-  [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr;
-    val_int;val_int;val_list val_sortfam;val_array val_constr;val_array val_int;
-    val_wfp;val_int;val_int;no_val|]
-
-
-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;
+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')
 
-  (* Number of expected parameters *)
-    mind_nparams : int;
+let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
 
-  (* Number of recursively uniform (i.e. ordinary) parameters *)
-    mind_nparams_rec : int;
+let subst_template_cst_arity sub (ctx,s as arity) =
+  let ctx' = subst_rel_context sub ctx in
+    if ctx==ctx' then arity else (ctx',s)
 
-  (* The context of parameters (includes let-in declaration) *)
-    mind_params_ctxt : rel_context;
+let subst_arity sub s = subst_decl_arity subst_mps subst_template_cst_arity sub s
 
-  (* Universes constraints enforced by the inductive declaration *)
-    mind_constraints : Univ.constraints;
+(* TODO: should be changed to non-coping after Term.subst_mps *)
+(* NB: we leave bytecode and native code fields untouched *)
+let subst_const_body sub cb =
+ { cb with
+    const_body = subst_constant_def sub cb.const_body;
+    const_type = subst_arity sub cb.const_type }
 
-  }
-let val_ind_pack = val_tuple ~name:"mutual_inductive_body"
-  [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt;
-    val_int; val_int; val_rctxt;val_cstrs|]
 
+let subst_regular_ind_arity sub s =
+  let uar' = subst_mps sub s.mind_user_arity in
+    if uar' == s.mind_user_arity then s 
+    else { mind_user_arity = uar'; mind_sort = s.mind_sort }
 
-let subst_arity sub = function
-| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
-| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+let subst_template_ind_arity sub s = 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 = subst_constant_def 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_constraints = cb.const_constraints}
-
-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
+(* FIXME records *)
+let subst_ind_arity =
+  subst_decl_arity subst_regular_ind_arity subst_template_ind_arity
 
 let subst_mind_packet sub mbp =
   { mind_consnames = mbp.mind_consnames;
     mind_consnrealdecls = mbp.mind_consnrealdecls;
+    mind_consnrealargs = mbp.mind_consnrealargs;
     mind_typename = mbp.mind_typename;
-   mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
+    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_arity = subst_ind_arity sub mbp.mind_arity;
+    mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
-    mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
+    mind_nrealdecls = mbp.mind_nrealdecls;
     mind_kelim = mbp.mind_kelim;
     mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
     mind_nb_constant = mbp.mind_nb_constant;
@@ -733,146 +566,49 @@ let subst_mind_packet sub mbp =
 
 
 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  }
+  { mib with
+    mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt;
+    mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets }
 
 (* Modules *)
 
-(* Whenever you change these types, please do update the validation
-   functions below *)
-type structure_field_body =
-  | SFBconst of constant_body
-  | SFBmind of mutual_inductive_body
-  | SFBmodule of module_body
-  | 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
-  | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints
-  | SEBstruct of structure_body
-  | SEBwith of struct_expr_body * with_declaration_body
-
-and with_declaration_body =
-    With_module_body of identifier list * module_path
-  | With_definition_body of  identifier list * constant_body
-
-and module_body =
-    { mod_mp : module_path;
-      mod_expr : struct_expr_body option; 
-      mod_type : struct_expr_body;
-      mod_type_alg : struct_expr_body option;
-      mod_constraints : Univ.constraints;
-      mod_delta : delta_resolver;
-      mod_retroknowledge : action list}
-
-and module_type_body =
-    { typ_mp : module_path;
-      typ_expr : struct_expr_body;
-      typ_expr_alg : struct_expr_body option ;
-      typ_constraints : Univ.constraints;
-      typ_delta :delta_resolver}
-
-(* the validation functions: *)
-let rec val_sfb o = val_sum "struct_field_body" 0
-  [|[|val_cb|];       (* SFBconst *)
-    [|val_ind_pack|]; (* SFBmind *)
-    [|val_module|];   (* SFBmodule *)
-    [|val_modtype|]   (* SFBmodtype *)
-  |] o
-and val_sb o = val_list (val_tuple ~name:"label*sfb"[|val_id;val_sfb|]) o
-and val_seb o = val_sum "struct_expr_body" 0
-  [|[|val_mp|];                      (* SEBident *)
-    [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *)
-    [|val_seb;val_seb;val_cstrs|];   (* SEBapply *)
-    [|val_sb|];              (* SEBstruct *)
-    [|val_seb;val_with|]             (* SEBwith *)
-  |] o
-and val_with o = val_sum "with_declaration_body" 0
-  [|[|val_list val_id;val_mp|];
-    [|val_list val_id;val_cb|]|] o
-and val_module o = val_tuple ~name:"module_body"
-  [|val_mp;val_opt val_seb;val_seb;
-    val_opt val_seb;val_cstrs;val_res;no_val|] o
-and val_modtype o = val_tuple ~name:"module_type_body"
-  [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o
-
-
-let rec subst_with_body sub = function
-  | With_module_body(id,mp) ->
-      With_module_body(id,subst_mp sub mp)
-  | With_definition_body(id,cb) ->
-      With_definition_body( id,subst_const_body sub cb)
-
-and subst_modtype sub mtb=
-  let typ_expr' = subst_struct_expr sub mtb.typ_expr in
-  let typ_alg' = 
-    Option.smartmap 
-      (subst_struct_expr sub) mtb.typ_expr_alg in
-  let mp = subst_mp sub mtb.typ_mp
-  in
-    if typ_expr'==mtb.typ_expr && 
-      typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then
-	mtb
-    else
-      {mtb with 
-	 typ_mp = mp;
-	 typ_expr = typ_expr';
-	 typ_expr_alg = typ_alg'}
+let rec functor_map fty f0 = function
+  | NoFunctor a -> NoFunctor (f0 a)
+  | MoreFunctor (mbid,ty,e) -> MoreFunctor(mbid,fty ty,functor_map fty f0 e)
 
-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)
-  in
-    List.map (fun (l,b) -> (l,subst_body b)) sign
+let implem_map fs fa = function
+  | Struct s -> Struct (fs s)
+  | Algebraic a -> Algebraic (fa a)
+  | impl -> impl
 
+let subst_with_body sub = function
+  | WithMod(id,mp) -> WithMod(id,subst_mp sub mp)
+  | WithDef(id,c) -> WithDef(id,subst_mps sub c)
 
-and subst_module sub mb =
-  let mtb' = subst_struct_expr sub mb.mod_type in
-  let typ_alg' = Option.smartmap 
-    (subst_struct_expr sub ) mb.mod_type_alg in
-  let me' = Option.smartmap 
-    (subst_struct_expr sub) mb.mod_expr in
-  let mp = subst_mp sub mb.mod_mp in
-     if mtb'==mb.mod_type && mb.mod_expr == me' 
-       && mp == mb.mod_mp
-    then mb else
-      { mb with
-	  mod_mp = mp;
-	  mod_expr = me';
-	  mod_type_alg = typ_alg';
-	  mod_type=mtb'}
-
-and subst_struct_expr sub = function
-    | SEBident mp -> SEBident (subst_mp sub mp)
-    | SEBfunctor (mbid, mtb, meb') -> 
-	SEBfunctor(mbid,subst_modtype sub mtb
-		     ,subst_struct_expr sub meb')
-    | SEBstruct (str)->
-	SEBstruct( 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 rec subst_expr sub = function
+  | MEident mp -> MEident (subst_mp sub mp)
+  | MEapply (me1,mp2)-> MEapply (subst_expr sub me1, subst_mp sub mp2)
+  | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd)
+
+let rec subst_expression sub me =
+  functor_map (subst_module sub) (subst_expr sub) me
 
+and subst_signature sub sign =
+  functor_map (subst_module sub) (subst_structure sub) sign
 
+and subst_structure sub struc =
+  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_module sub mtb)
+  in
+  List.map (fun (l,b) -> (l,subst_body b)) struc
+
+and subst_module sub mb =
+  { mb with
+    mod_mp = subst_mp sub mb.mod_mp;
+    mod_expr =
+      implem_map (subst_signature sub) (subst_expression sub) mb.mod_expr;
+    mod_type = subst_signature sub mb.mod_type;
+    mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg }
diff --git a/checker/declarations.mli b/checker/declarations.mli
index 90beb326..3c6db6ab 100644
--- a/checker/declarations.mli
+++ b/checker/declarations.mli
@@ -1,238 +1,47 @@
-open Util
 open Names
-open Term
+open Cic
 
-(* 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 force_lazy_constr_univs : Cic.constant_def -> Univ.constraints
 val from_val : constr -> constr_substituted
 
-(** Beware! In .vo files, lazy_constr are stored as integers
-   used as indexes for a separate table. The actual lazy_constr is restored
-   later, by [Safe_typing.LightenLibrary.load]. This allows us
-   to use here a different definition of lazy_constr than coqtop:
-   since the checker will inspect all proofs parts, even opaque
-   ones, no need to use Lazy.t here *)
-
-type lazy_constr
-val force_lazy_constr : lazy_constr -> constr
-val lazy_constr_from_val : constr_substituted -> lazy_constr
+val indirect_opaque_access : (DirPath.t -> int -> constr) ref
+val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.constraints) ref
 
-(** Inlining level of parameters at functor applications.
-    This is ignored by the checker. *)
+(** Constant_body *)
 
-type inline = int option
-
-(** A constant can have no body (axiom/parameter), or a
-    transparent body, or an opaque one *)
-
-type constant_def =
-  | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
-
-type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constant_def;
-    const_type : constant_type;
-    const_body_code : to_patch_substituted;
-    const_constraints : Univ.constraints }
-
-val body_of_constant : constant_body -> constr_substituted option
+val body_of_constant : constant_body -> constr option
 val constant_has_body : constant_body -> bool
 val is_opaque : constant_body -> bool
 
 (* Mutual inductives *)
 
-type recarg =
-  | Norec
-  | Mrec of inductive
-  | 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_recarg : wf_paths -> recarg
 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;
-
- (* Length of realargs context (with let, no params) *)
-    mind_nrealargs_ctxt : 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;
-
-  }
+val eq_recarg : recarg -> recarg -> bool
+val eq_wf_paths : wf_paths -> wf_paths -> bool
 
 (* Modules *)
 
-type substitution
-type delta_resolver
 val empty_delta_resolver : delta_resolver
 
-type structure_field_body =
-  | SFBconst of constant_body
-  | SFBmind of mutual_inductive_body
-  | SFBmodule of module_body
-  | 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
-  | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints
-  | SEBstruct of structure_body
-  | SEBwith of struct_expr_body * with_declaration_body
-
-and with_declaration_body =
-    With_module_body of identifier list * module_path
-  | With_definition_body of  identifier list * constant_body
-
-and module_body =
-    { mod_mp : module_path;
-      mod_expr : struct_expr_body option; 
-      mod_type : struct_expr_body;
-      mod_type_alg : struct_expr_body option;
-      mod_constraints : Univ.constraints;
-      mod_delta : delta_resolver;
-      mod_retroknowledge : action list}
-
-and module_type_body =
-    { typ_mp : module_path;
-      typ_expr : struct_expr_body;
-      typ_expr_alg : struct_expr_body option ;
-      typ_constraints : Univ.constraints;
-      typ_delta :delta_resolver}
-
 (* Substitutions *)
 
 type 'a subst_fun = substitution -> 'a -> 'a
 
 val empty_subst : substitution
-val add_mbid : mod_bound_id -> module_path -> substitution -> substitution
+val add_mbid : MBId.t -> module_path -> substitution -> substitution
 val add_mp   : module_path -> module_path -> substitution -> substitution
-val map_mbid : mod_bound_id -> module_path -> substitution
+val map_mbid : MBId.t -> module_path -> substitution
 val map_mp   : module_path -> module_path -> substitution
 val mp_in_delta : module_path -> delta_resolver -> bool
 val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
 
 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 :  substitution -> module_signature -> module_signature
 val subst_module : substitution -> module_body -> module_body
 
 val join : substitution -> substitution -> substitution
-
-(* Validation *)
-val val_eng : Validate.func
-val val_module : Validate.func
-val val_modtype : Validate.func
diff --git a/checker/environ.ml b/checker/environ.ml
index 99b36457..710ebc71 100644
--- a/checker/environ.ml
+++ b/checker/environ.ml
@@ -1,6 +1,7 @@
+open Errors
 open Util
 open Names
-open Univ
+open Cic
 open Term
 open Declarations
 
@@ -12,16 +13,15 @@ type globals = {
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
-  env_universes : universes;
+  env_universes : Univ.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 }
+    env_imports : Cic.vodigest MPmap.t }
 
 let empty_env = {
   env_globals =
@@ -30,7 +30,6 @@ let empty_env = {
     env_inductives_eq = KNmap.empty;
     env_modules = MPmap.empty;
     env_modtypes = MPmap.empty};
-  env_named_context = [];
   env_rel_context = [];
   env_stratification =
   { env_universes = Univ.initial_universes;
@@ -39,7 +38,6 @@ let empty_env = {
 
 let engagement env = env.env_stratification.env_engagement
 let universes env = env.env_stratification.env_universes
-let named_context env = env.env_named_context
 let rel_context env = env.env_rel_context
 
 let set_engagement c env =
@@ -73,46 +71,31 @@ let push_rel d env =
 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
+  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 == empty_constraint then
+  if c == Univ.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 } }
+      { s with env_universes = Univ.merge_constraints c s.env_universes } }
+
+let check_constraints cst env =
+  Univ.check_constraints cst env.env_stratification.env_universes
 
 (* Global constants *)
 
 let lookup_constant kn env =
   Cmap_env.find kn env.env_globals.env_constants
 
+let anomaly s = anomaly (Pp.str s)
+
 let add_constant kn cs env =
   if Cmap_env.mem kn env.env_globals.env_constants then
-    Printf.ksprintf anomaly "Constant %s is already defined"
+    Printf.ksprintf anomaly ("Constant %s is already defined")
       (string_of_con kn);
   let new_constants =
     Cmap_env.add kn cs env.env_globals.env_constants in
@@ -123,20 +106,52 @@ let add_constant kn cs env =
 
 type const_evaluation_result = NoBody | Opaque
 
+(* Constant types *)
+
+let constraints_of cb u =
+  let univs = cb.const_universes in
+    Univ.subst_instance_constraints u (Univ.UContext.constraints univs)
+
+let map_regular_arity f = function
+  | RegularArity a as ar -> 
+    let a' = f a in 
+      if a' == a then ar else RegularArity a'
+  | TemplateArity _ -> assert false
+
+(* constant_type gives the type of a constant *)
+let constant_type env (kn,u) =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then
+      let csts = constraints_of cb u in
+	(map_regular_arity (subst_instance_constr u) cb.const_type, csts)
+    else cb.const_type, Univ.Constraint.empty
+
 exception NotEvaluableConst of const_evaluation_result
 
-let constant_value env kn =
+let constant_value env (kn,u) =
   let cb = lookup_constant kn env in
-  match cb.const_body with
-    | Def l_body -> force_constr l_body
+    match cb.const_body with
+    | Def l_body -> 
+      let b = force_constr l_body in
+	if cb.const_polymorphic then
+	  subst_instance_constr u (force_constr l_body)
+	else b
     | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
     | Undef _ -> raise (NotEvaluableConst NoBody)
 
 (* 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
+  try let _  = constant_value env (cst, Univ.Instance.empty) in true
   with Not_found | NotEvaluableConst _ -> false
 
+let is_projection cst env = 
+  not (Option.is_empty (lookup_constant cst env).const_proj)
+
+let lookup_projection cst env =
+  match (lookup_constant cst env).const_proj with 
+  | Some pb -> pb
+  | None -> anomaly ("lookup_projection: constant is not a projection")
+
 (* Mutual Inductives *)
 let scrape_mind env kn=
   try
@@ -145,8 +160,8 @@ let scrape_mind env kn=
       Not_found -> kn
 
 let mind_equiv env (kn1,i1) (kn2,i2) =
-  i1 = i2 && 
-  scrape_mind env (user_mind kn1) = scrape_mind env (user_mind kn2)
+  Int.equal i1 i2 &&
+  KerName.equal (scrape_mind env (user_mind kn1)) (scrape_mind env (user_mind kn2))
 
 
 let lookup_mind kn env =
@@ -154,11 +169,11 @@ let lookup_mind kn env =
 
 let add_mind kn mib env =
   if Mindmap_env.mem kn env.env_globals.env_inductives then
-    Printf.ksprintf anomaly "Inductive %s is already defined"
+    Printf.ksprintf anomaly ("Inductive %s is already defined")
       (string_of_mind kn);
   let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
   let kn1,kn2 =  user_mind kn,canonical_mind kn in
-  let new_inds_eq = if kn1=kn2 then 
+  let new_inds_eq = if KerName.equal kn1 kn2 then
     env.env_globals.env_inductives_eq
   else
     KNmap.add kn1 kn2  env.env_globals.env_inductives_eq in
@@ -173,7 +188,7 @@ let add_mind kn mib env =
 
 let add_modtype ln mtb env =
   if MPmap.mem ln env.env_globals.env_modtypes then
-    Printf.ksprintf anomaly "Module type %s is already defined"
+    Printf.ksprintf anomaly ("Module type %s is already defined")
       (string_of_mp ln);
   let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
   let new_globals =
@@ -183,7 +198,7 @@ let add_modtype ln mtb env =
 
 let shallow_add_module mp mb env =
   if MPmap.mem mp env.env_globals.env_modules then
-    Printf.ksprintf anomaly "Module %s is already defined"
+    Printf.ksprintf anomaly ("Module %s is already defined")
       (string_of_mp mp);
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
   let new_globals =
@@ -193,7 +208,7 @@ let shallow_add_module mp mb env =
 
 let shallow_remove_module mp env =
   if not (MPmap.mem mp env.env_globals.env_modules) then
-    Printf.ksprintf anomaly "Module %s is unknown"
+    Printf.ksprintf anomaly ("Module %s is unknown")
       (string_of_mp mp);
   let new_mods = MPmap.remove mp env.env_globals.env_modules in
   let new_globals =
diff --git a/checker/environ.mli b/checker/environ.mli
index 628febbb..d3448b12 100644
--- a/checker/environ.mli
+++ b/checker/environ.mli
@@ -1,34 +1,33 @@
 open Names
-open Term
+open Cic
 
 (* Environments *)
 
 type globals = {
-  env_constants : Declarations.constant_body Cmap_env.t;
-  env_inductives : Declarations.mutual_inductive_body Mindmap_env.t;
+  env_constants : constant_body Cmap_env.t;
+  env_inductives : mutual_inductive_body Mindmap_env.t;
   env_inductives_eq : kernel_name KNmap.t;
-  env_modules : Declarations.module_body MPmap.t;
-  env_modtypes : Declarations.module_type_body MPmap.t}
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body MPmap.t}
 type stratification = {
   env_universes : Univ.universes;
-  env_engagement : Declarations.engagement option;
+  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;
+  env_imports : Cic.vodigest MPmap.t;
 }
 val empty_env : env
 
 (* Engagement *)
-val engagement : env -> Declarations.engagement option
-val set_engagement : Declarations.engagement -> env -> env
+val engagement : env -> Cic.engagement option
+val set_engagement : Cic.engagement -> env -> env
 
 (* Digests *)
-val add_digest : env -> dir_path -> Digest.t -> env
-val lookup_digest : env -> dir_path -> Digest.t
+val add_digest : env -> DirPath.t -> Cic.vodigest -> env
+val lookup_digest : env -> DirPath.t -> Cic.vodigest
 
 (* de Bruijn variables *)
 val rel_context : env -> rel_context
@@ -37,38 +36,37 @@ val push_rel : rel_declaration -> env -> env
 val push_rel_context : rel_context -> env -> env
 val push_rec_types : name array * constr array * 'a -> env -> env
 
-(* Named variables *)
-val named_context : env -> named_context
-val push_named : named_declaration -> env -> env
-val lookup_named : identifier -> env -> named_declaration
-val named_type : identifier -> env -> constr
-
 (* Universes *)
 val universes : env -> Univ.universes
 val add_constraints : Univ.constraints -> env -> env
+val check_constraints : Univ.constraints -> env -> bool
 
 (* Constants *)
-val lookup_constant : constant -> env -> Declarations.constant_body
-val add_constant : constant -> Declarations.constant_body -> env -> env
+val lookup_constant : constant -> env -> Cic.constant_body
+val add_constant : constant -> Cic.constant_body -> env -> env
+val constant_type : env -> constant puniverses -> constant_type Univ.constrained
 type const_evaluation_result = NoBody | Opaque
 exception NotEvaluableConst of const_evaluation_result
-val constant_value : env -> constant -> constr
+val constant_value : env -> constant puniverses -> constr
 val evaluable_constant : constant -> env -> bool
 
+val is_projection : constant -> env -> bool
+val lookup_projection : constant -> env -> projection_body
+
 (* Inductives *)
 val mind_equiv : env -> inductive -> inductive -> bool
 
 val lookup_mind :
-  mutual_inductive -> env -> Declarations.mutual_inductive_body
+  mutual_inductive -> env -> Cic.mutual_inductive_body
 
 val add_mind :
-  mutual_inductive -> Declarations.mutual_inductive_body -> env -> env
+  mutual_inductive -> Cic.mutual_inductive_body -> env -> env
 
 (* Modules *)
 val add_modtype :
-  module_path -> Declarations.module_type_body -> env -> env
+  module_path -> Cic.module_type_body -> env -> env
 val shallow_add_module :
-  module_path -> Declarations.module_body -> env -> env
+  module_path -> Cic.module_body -> env -> env
 val shallow_remove_module : module_path -> env -> env
-val lookup_module : module_path -> env -> Declarations.module_body
-val lookup_modtype : module_path -> env -> Declarations.module_type_body
+val lookup_module : module_path -> env -> Cic.module_body
+val lookup_modtype : module_path -> env -> Cic.module_type_body
diff --git a/checker/include b/checker/include
index b7d46d4b..f5bd2984 100644
--- a/checker/include
+++ b/checker/include
@@ -12,10 +12,12 @@
 #directory "lib";;
 #directory "kernel";;
 #directory "checker";;
+#directory "+threads";;
 #directory "+camlp4";;
 #directory "+camlp5";;
 
 #load "unix.cma";;
+#load"threads.cma";;
 #load "str.cma";;
 #load "gramlib.cma";;
 (*#load "toplevellib.cma";;
@@ -29,12 +31,14 @@ open Typeops;;
 open Check;;
 
 open Pp;;
+open Errors;;
 open Util;;
 open Names;;
 open Term;;
 open Environ;;
 open Declarations;;
 open Mod_checking;;
+open Cic;;
 
 let pr_id id = str(string_of_id id)
 let pr_na = function Name id -> pr_id id | _ -> str"_";;
@@ -111,23 +115,33 @@ let prsub s =
 (*#install_printer prenvu;;
 #install_printer prsub;;*)
 
-Checker.init_with_argv [|""|];;
+Checker.init_with_argv [|"";"-coqlib";"."|];;
 Flags.make_silent false;;
 Flags.debug := true;;
 Sys.catch_break true;;
 
 let module_of_file f =
   let (_,mb,_,_) = Obj.magic ((intern_from_file f).library_compiled) in
-  (mb:module_body)
+  (mb:Cic.module_body)
 ;;
+let deref_mod md s =
+  let l = match md.mod_expr with
+      Struct(NoFunctor l) -> l 
+    | FullStruct ->
+      (match md.mod_type with
+	NoFunctor l -> l)
+ in
+  List.assoc (label_of_id(id_of_string s)) l
+;;
+(*
 let mod_access m fld =
   match m.mod_expr with
       Some(SEBstruct l) -> List.assoc fld l
     | _ -> failwith "bad structure type"
 ;;
-
+*)
 let parse_dp s =
-  make_dirpath(List.map id_of_string (List.rev (Str.split(Str.regexp"\\.") s)))
+  make_dirpath(List.rev_map id_of_string (Str.split(Str.regexp"\\.") s))
 ;;
 let parse_sp s =
   let l = List.rev (Str.split(Str.regexp"\\.") s) in
@@ -160,10 +174,6 @@ let read_mod s f =
     (dir_path * Digest.t) list *
     engagement option);;
 
-let deref_mod md s =
-  let (Some (SEBstruct l)) = md.mod_expr in
-  List.assoc (label_of_id(id_of_string s)) l
-;;
 
 let expln f x =
   try f x
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
index 1207a325..2ce9f038 100644
--- a/checker/indtypes.ml
+++ b/checker/indtypes.ml
@@ -1,14 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
-open Univ
+open Cic
 open Term
 open Inductive
 open Reduction
@@ -18,25 +19,25 @@ open Declarations
 open Environ
 
 let rec debug_string_of_mp = function
-  | MPfile sl -> string_of_dirpath sl
-  | MPbound uid -> "bound("^string_of_mbid uid^")"
-  | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ string_of_label l
+  | MPfile sl -> DirPath.to_string sl
+  | MPbound uid -> "bound("^MBId.to_string uid^")"
+  | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ Label.to_string l
 
 let rec string_of_mp = function
-  | MPfile sl -> string_of_dirpath sl
-  | MPbound uid -> string_of_mbid uid
-  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
+  | MPfile sl -> DirPath.to_string sl
+  | MPbound uid -> MBId.to_string uid
+  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ Label.to_string l
 
 let string_of_mp mp =
   if !Flags.debug then debug_string_of_mp mp else string_of_mp mp
 
 let prkn kn =
   let (mp,_,l) = repr_kn kn in
-  str(string_of_mp mp ^ "." ^ string_of_label l)
+  str(string_of_mp mp ^ "." ^ Label.to_string l)
 let prcon c =
   let ck = canonical_con c in
   let uk = user_con c in
-  if ck=uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")")
+  if KerName.equal ck uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")")
 
 (* Same as noccur_between but may perform reductions.
    Could be refined more...  *)
@@ -75,10 +76,10 @@ type inductive_error =
   | 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
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
+  | NotAnArity of Id.t
   | BadEntry
 
 exception InductiveError of inductive_error
@@ -99,7 +100,7 @@ let rec sorts_of_constr_args env t =
         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"
+    | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor")
 
 
 (* Prop and Set are small *)
@@ -107,7 +108,9 @@ let is_small_sort = function
   | Prop _ -> true
   | _ -> false
 
-let is_logic_sort s = (s = Prop Null)
+let is_logic_sort = function
+| Prop Null -> true
+| _ -> false
 
 (* [infos] is a sequence of pair [islogic,issmall] for each type in
    the product of a constructor or arity *)
@@ -126,7 +129,7 @@ let is_unit constrsinfos =
    | _ -> false
 
 let small_unit constrsinfos =
-  let issmall = array_for_all is_small_constr constrsinfos
+  let issmall = Array.for_all is_small_constr constrsinfos
   and isunit = is_unit constrsinfos in
   issmall, isunit
 
@@ -135,14 +138,15 @@ let typecheck_arity env params inds =
   let nparamargs = rel_context_nhyps params in
   let nparamdecls = rel_context_length params in
   let check_arity arctxt = function
-      Monomorphic mar ->
+    | RegularArity 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
+    | TemplateArity par ->
+      check_polymorphic_arity env params par;
+      it_mkProd_or_LetIn (Sort(Type par.template_level)) arctxt 
+  in
   let env_arities =
     Array.fold_left
       (fun env_ar ind ->
@@ -156,7 +160,7 @@ let typecheck_arity env params inds =
         if ind.mind_nrealargs <> nrealargs then
              failwith "bad number of real inductive arguments";
 	let nrealargs_ctxt = rel_context_length ar_ctxt - nparamdecls in
-        if ind.mind_nrealargs_ctxt <> nrealargs_ctxt then
+        if ind.mind_nrealdecls <> nrealargs_ctxt then
              failwith "bad length of real inductive arguments signature";
 	(* We do not need to generate the universe of full_arity; if
 	   later, after the validation of the inductive definition,
@@ -174,11 +178,11 @@ let typecheck_arity env params inds =
 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 empty_constraint)
-            (universes env) in
-        if not (check_geq cst u' level) then
+        (* let u' = fresh_local_univ () in *)
+        (* let cst = *)
+        (*   merge_constraints (enforce_leq u u' empty_constraint) *)
+        (*     (universes env) in *)
+        if not (Univ.check_leq (universes env) level u) then
           failwith "impredicative Type inductive type"
     | Prop Pos, Some ImpredicativeSet -> ()
     | Prop Pos, _ ->
@@ -187,8 +191,8 @@ let check_predicativity env s small level =
 
 
 let sort_of_ind = function
-    Monomorphic mar -> mar.mind_sort
-  | Polymorphic par -> Type par.poly_level
+  | RegularArity mar -> mar.mind_sort
+  | TemplateArity par -> Type par.template_level
 
 let all_sorts = [InProp;InSet;InType]
 let small_sorts = [InProp;InSet]
@@ -207,7 +211,7 @@ let allowed_sorts issmall isunit s =
 
   (* 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 *)
+  (* which otherwise allows simulating the inconsistent system Type:Type *)
   | InProp when isunit -> if issmall then all_sorts else small_sorts
 
   (* Other propositions: elimination only to Prop *)
@@ -242,17 +246,18 @@ let typecheck_one_inductive env params mib mip =
   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;
+  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;
+  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
+  let reject_sort s = not (List.mem_f family_equal s sorts) in
+  if List.exists reject_sort mip.mind_kelim then
     failwith "elimination not allowed";
   (* mind_recargs: checked by positivity criterion *)
   ()
@@ -298,11 +303,11 @@ let failwith_non_pos n ntypes c =
 
 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"
+  anomaly ~label:"failwith_non_pos_vect" (Pp.str "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"
+  anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur")
 
 (* Conclusion of constructors: check the inductive type is called with
    the expected parameters *)
@@ -311,7 +316,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
   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 (lpar,largs') = Array.chop nparams largs in
   let nhyps = List.length hyps in
   let rec check k index = function
     | [] -> ()
@@ -321,7 +326,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
 	  | 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
+  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.
@@ -330,7 +335,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
     recursive parameters *)
 
 let check_rec_par (env,n,_,_) hyps nrecp largs =
-  let (lpar,_) = list_chop nrecp largs in
+  let (lpar,_) = List.chop nrecp largs in
   let rec find index =
     function
       | ([],_) -> ()
@@ -354,8 +359,8 @@ let abstract_mind_lc env ntyps npars lc =
     lc
   else
     let make_abs =
-      list_tabulate
-	(function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps
+      List.init ntyps
+	(function i -> lambda_implicit_lift npars (Rel (i+1)))
     in
     Array.map (substl make_abs) lc
 
@@ -368,12 +373,12 @@ let abstract_mind_lc env ntyps npars lc =
 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 ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),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
+              hnf_prod_applist env (type_of_inductive env (specif,u)) 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
@@ -399,7 +404,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
     let x,largs = decompose_app (whd_betadeltaiota env c) in
       match x with
 	| Prod (na,b,d) ->
-	    assert (largs = []);
+	    assert (List.is_empty largs);
             (match weaker_noccur_between env n ntypes b with
 		None -> failwith_non_pos_list n ntypes [b]
               | Some b ->
@@ -426,12 +431,12 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
 	    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) =
+  and check_positive_imbr (env,n,ntypes,ra_env as ienv) ((mi,u), largs) =
     let (mib,mip) = lookup_mind_specif env mi in
     let auxnpar = mib.mind_nparams_rec in
     let nonrecpar = mib.mind_nparams - auxnpar in
     let (lpar,auxlargs) =
-      try list_chop auxnpar largs
+      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. *)
@@ -444,7 +449,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
 	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
+	let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in
 	  (* Parameters expressed in env' *)
 	let lpar' = List.map (lift auxntyp) lpar in
 	let irecargs =
@@ -468,16 +473,17 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
       let x,largs = decompose_app (whd_betadeltaiota env c) in
 	match x with
           | Prod (na,b,d) ->
-	      assert (largs = []);
+	      assert (List.is_empty 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
+                match hd with
+		| Rel j when j = (n + ntypes - i - 1) ->
 		  check_correct_par ienv hyps (ntypes-i) largs
-		else
+		| _ ->
 		  raise (IllFormedInd LocalNotConstructor)
 	      else
 		if not (List.for_all (noccur_between n ntypes) largs)
@@ -496,13 +502,10 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc
       indlc
   in mk_paths (Mrec ind) 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"
+let check_subtree t1 t2 =
+  let cmp_labels l1 l2 = l1 == Norec || eq_recarg l1 l2 in
+  if not (Rtree.equiv eq_recarg cmp_labels t1 t2)
+  then failwith "bad recursive trees"
 (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*)
 
 let check_positivity env_ar mind params nrecp inds =
@@ -513,29 +516,26 @@ let check_positivity env_ar mind params nrecp inds =
   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
+      List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
       check_positivity_one ienv params nrecp (mind,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
+  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: " ++ pr_mind kn);
+  Flags.if_verbose ppnl (str "  checking ind: " ++ pr_mind kn); pp_flush ();
   (* check mind_constraints: should be consistent with env *)
-  let env = add_constraints mib.mind_constraints env in
+  let env = add_constraints (Univ.UContext.constraints mib.mind_universes) 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
diff --git a/checker/indtypes.mli b/checker/indtypes.mli
index 6093752d..5188f80d 100644
--- a/checker/indtypes.mli
+++ b/checker/indtypes.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,10 +8,7 @@
 
 (*i*)
 open Names
-open Univ
-open Term
-open Typeops
-open Declarations
+open Cic
 open Environ
 (*i*)
 
@@ -27,10 +24,10 @@ type inductive_error =
   | 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
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
+  | NotAnArity of Id.t
   | BadEntry
 
 exception InductiveError of inductive_error
diff --git a/checker/inductive.ml b/checker/inductive.ml
index 1e12f610..59d1a645 100644
--- a/checker/inductive.ml
+++ b/checker/inductive.ml
@@ -1,19 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
-open Univ
+open Cic
 open Term
 open Reduction
 open Type_errors
 open Declarations
 open Environ
+open Univ
 
 let inductive_of_constructor = fst
 let index_of_constructor = snd
@@ -37,42 +39,60 @@ let find_rectype env c =
 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)
+    | Ind (ind,_)
+        when (fst (lookup_mind_specif env ind)).mind_finite != CoFinite -> (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)
+    | Ind (ind,_)
+        when (fst (lookup_mind_specif env ind)).mind_finite == CoFinite -> (ind, l)
     | _ -> raise Not_found
 
 let inductive_params (mib,_) = mib.mind_nparams
 
+(** Polymorphic inductives *)
+
+let inductive_instance mib =
+  if mib.mind_polymorphic then
+    UContext.instance mib.mind_universes
+  else Instance.empty
+
+let inductive_context mib =
+  if mib.mind_polymorphic then 
+    instantiate_univ_context mib.mind_universes 
+  else UContext.empty
+
+let instantiate_inductive_constraints mib u =
+  if mib.mind_polymorphic then
+    subst_instance_constraints u (UContext.constraints mib.mind_universes)
+  else Constraint.empty
+
 (************************************************************************)
 
 (* Build the substitution that replaces Rels by the appropriate *)
 (* inductives *)
-let ind_subst mind mib =
+let ind_subst mind mib u =
   let ntypes = mib.mind_ntypes in
-  let make_Ik k = Ind (mind,ntypes-k-1) in
-  list_tabulate make_Ik ntypes
+  let make_Ik k = Ind ((mind,ntypes-k-1),u) in
+  List.init ntypes make_Ik
 
 (* Instantiate inductives in constructor type *)
-let constructor_instantiate mind mib c =
-  let s = ind_subst mind mib in
-  substl s c
+let constructor_instantiate mind u mib c =
+  let s = ind_subst mind mib u in
+  substl s (subst_instance_constr u c)
 
-let instantiate_params full t args sign =
+let instantiate_params full t u args sign =
   let fail () =
-    anomaly "instantiate_params: type, ctxt and args mismatch" in
+    anomaly ~label:"instantiate_params" (Pp.str "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)
+          | (Some b,_,LetIn(_,_,_,t))    -> 
+	    (largs, (substl subs (subst_instance_constr u b))::subs, t)
 	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
 	  | _                       -> fail ())
       sign
@@ -81,15 +101,15 @@ let instantiate_params full t args sign =
   if rem_args <> [] then fail();
   substl subs ty
 
-let full_inductive_instantiate mib params sign =
+let full_inductive_instantiate mib u params sign =
   let dummy = Prop Null in
   let t = mkArity (sign,dummy) in
-  fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
+    fst (destArity (instantiate_params true t u params mib.mind_params_ctxt))
 
-let full_constructor_instantiate ((mind,_),(mib,_),params) =
-  let inst_ind = constructor_instantiate mind mib in
+let full_constructor_instantiate ((mind,_),u,(mib,_),params) =
+  let inst_ind = constructor_instantiate mind u mib in
   (fun t ->
-    instantiate_params true (inst_ind t) params mib.mind_params_ctxt)
+    instantiate_params true (inst_ind t) u params mib.mind_params_ctxt)
 
 (************************************************************************)
 (************************************************************************)
@@ -119,12 +139,11 @@ Remark: Set (predicative) is encoded as Type(0)
 
 let sort_as_univ = function
 | Type u -> u
-| Prop Null -> type0m_univ
-| Prop Pos -> type0_univ
+| Prop Null -> Univ.type0m_univ
+| Prop Pos -> Univ.type0_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
+  Univ.LMap.add u su subst
 
 let actualize_decl_level env lev t =
   let sign,s = dest_arity env t in
@@ -157,65 +176,112 @@ let rec make_subst env = function
       (* (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,[]
+      sign,Univ.LMap.empty
   | [], _, _ ->
       assert false
 
+
+exception SingletonInductiveBecomesProp of Id.t
+
 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_type0m_univ level then Prop Null
-  else if is_type0_univ level then Prop Pos
-  else Type level
-
-let type_of_inductive_knowing_parameters env mip paramtyps =
+  let ctx,subst = make_subst env (ctx,ar.template_param_levels,args) in
+  let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in
+  let ty =
+    (* Singleton type not containing types are interpretable in Prop *)
+    if Univ.is_type0m_univ level then Prop Null
+    (* Non singleton type not containing types are interpretable in Set *)
+    else if Univ.is_type0_univ level then Prop Pos
+    (* This is a Type with constraints *)
+    else Type level
+  in
+    (ctx, ty)
+
+(* Type of an inductive type *)
+
+let is_prop_sort = function
+  | Prop Null -> true
+  | _ -> false
+
+let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) 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
+  | RegularArity a ->
+    if not mib.mind_polymorphic then a.mind_user_arity
+    else subst_instance_constr u a.mind_user_arity
+  | TemplateArity ar ->
+    let ctx = List.rev mip.mind_arity_ctxt in
+    let ctx,s = instantiate_universes env ctx ar paramtyps in
+      (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e.
+         the situation where a non-Prop singleton inductive becomes Prop
+         when applied to Prop params *)
+      if not polyprop && not (Univ.is_type0m_univ ar.template_level) && is_prop_sort s
+      then raise (SingletonInductiveBecomesProp mip.mind_typename);
       mkArity (List.rev ctx,s)
 
+let type_of_inductive env pind = 
+  type_of_inductive_gen env pind [||]
+
+let constrained_type_of_inductive env ((mib,mip),u as pind) =
+  let ty = type_of_inductive_gen env pind [||] in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
+
+let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args =
+  let ty = type_of_inductive_gen env pind args in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
+
+let type_of_inductive_knowing_parameters env mip args = 
+  type_of_inductive_gen env mip args
+
 (* Type of a (non applied) inductive type *)
 
-let type_of_inductive env (_,mip) =
+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 type0_univ u
-  | Type u' -> sup u u'
+  | Prop Pos -> Univ.sup Univ.type0_univ u
+  | Type u' -> Univ.sup u u'
 
 let max_inductive_sort =
-  Array.fold_left cumulate_constructor_univ type0m_univ
+  Array.fold_left cumulate_constructor_univ Univ.type0m_univ
 
 (************************************************************************)
 (* Type of a constructor *)
 
-let type_of_constructor cstr (mib,mip) =
+let type_of_constructor_subst cstr u (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)
+  if i > nconstr then error "Not enough constructors in the type.";
+    constructor_instantiate (fst ind) u mib specif.(i-1)
 
-let arities_of_specif kn (mib,mip) =
+let type_of_constructor_gen (cstr,u) (mib,mip as mspec) =
+  type_of_constructor_subst cstr u mspec
+
+let type_of_constructor cstru mspec = 
+  type_of_constructor_gen cstru mspec
+
+let type_of_constructor_in_ctx cstr (mib,mip as mspec) =
+  let u = Univ.UContext.instance mib.mind_universes in
+  let c = type_of_constructor_gen (cstr, u) mspec in
+    (c, mib.mind_universes)
+
+let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) =
+  let ty = type_of_constructor_gen cstru ind in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
+
+let arities_of_specif (kn,u) (mib,mip) =
   let specif = mip.mind_nf_lc in
-  Array.map (constructor_instantiate kn mib) specif
+  Array.map (constructor_instantiate kn u mib) specif
 
 
 
@@ -233,15 +299,15 @@ let error_elim_expln kp ki =
 
 let inductive_sort_family mip =
   match mip.mind_arity with
-   | Monomorphic s -> family_of_sort s.mind_sort
-   | Polymorphic _ -> InType
+  | RegularArity s -> family_of_sort s.mind_sort
+  | TemplateArity _ -> InType
 
 let mind_arity mip =
   mip.mind_arity_ctxt, inductive_sort_family mip
 
-let get_instantiated_arity (mib,mip) params =
+let get_instantiated_arity (ind,u) (mib,mip) params =
   let sign, s = mind_arity mip in
-  full_inductive_instantiate mib params sign, s
+  full_inductive_instantiate mib u params sign, s
 
 let elim_sorts (_,mip) = mip.mind_kelim
 
@@ -254,10 +320,10 @@ let extended_rel_list n hyps =
   reln [] 1 hyps
 
 let build_dependent_inductive ind (_,mip) params =
-  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
   applist
     (Ind ind,
-       List.map (lift mip.mind_nrealargs_ctxt) params
+       List.map (lift mip.mind_nrealdecls) params
        @ extended_rel_list 0 realargs)
 
 (* This exception is local *)
@@ -269,7 +335,7 @@ let check_allowed_sort ksort specif =
     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 arsign,_ = get_instantiated_arity ind specif params in
   let rec srec env pt ar =
     let pt' = whd_betadeltaiota env pt in
     match pt', ar with
@@ -305,18 +371,18 @@ let is_correct_arity env c (p,pj) ind specif params =
 
 (* [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_branches_type (ind,u) (_,mip as specif) params dep p =
   let build_one_branch i cty =
-    let typi = full_constructor_instantiate (ind,specif,params) cty in
+    let typi = full_constructor_instantiate (ind,u,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 (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
+          applist (Construct (cstr,u),lparams@extended_rel_list 0 args) in
         vargs @ [dep_cstr]
       else
         vargs in
@@ -330,12 +396,12 @@ 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 type_case_branches env (pind,largs) (p,pj) c =
+  let specif = lookup_mind_specif env (fst pind) 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 (params,realargs) = List.chop nparams largs in
+  let dep = is_correct_arity env c (p,pj) pind specif params in
+  let lc = build_branches_type pind specif params dep p in
   let ty = build_case_type dep p c realargs in
   (lc, ty)
 
@@ -346,9 +412,10 @@ let type_case_branches env (ind,largs) (p,pj) c =
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
-    not (eq_ind indsp ci.ci_ind) or
-    (mib.mind_nparams <> ci.ci_npar) or
-    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
+    not (eq_ind indsp ci.ci_ind) ||
+    (mib.mind_nparams <> ci.ci_npar) ||
+    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) ||
+    (mip.mind_consnrealargs <> ci.ci_cstr_nargs)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -399,54 +466,70 @@ type subterm_spec =
   | Dead_code
   | Not_subterm
 
-let spec_of_tree t = lazy
-  (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec
-   then Not_subterm
-   else Subterm(Strict,Lazy.force t))
+let eq_recarg r1 r2 = match r1, r2 with
+| Norec, Norec -> true
+| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2
+| Imbr i1, Imbr i2 -> Names.eq_ind i1 i2
+| _ -> false
+
+let eq_wf_paths = Rtree.equal eq_recarg
+
+let pp_recarg = function
+  | Norec -> Pp.str "Norec"
+  | Mrec i -> Pp.str ("Mrec "^MutInd.to_string (fst i))
+  | Imbr i -> Pp.str ("Imbr "^MutInd.to_string (fst i))
+
+let pp_wf_paths = Rtree.pp_tree pp_recarg
+
+let inter_recarg r1 r2 = match r1, r2 with
+| Norec, Norec -> Some r1
+| Mrec i1, Mrec i2
+| Imbr i1, Imbr i2
+| Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None
+| Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None
+| _ -> None
+
+let inter_wf_paths = Rtree.inter eq_recarg inter_recarg Norec
+
+let incl_wf_paths = Rtree.incl eq_recarg inter_recarg Norec
+
+let spec_of_tree t =
+  if eq_wf_paths t mk_norec
+  then Not_subterm
+  else Subterm (Strict, t)
+
+let inter_spec s1 s2 =
+  match s1, s2 with
+  | _, Dead_code -> s1
+  | Dead_code, _ -> s2
+  | Not_subterm, _ -> s1
+  | _, Not_subterm -> s2
+  | Subterm (a1,t1), Subterm (a2,t2) ->
+     Subterm (size_glb a1 a2, inter_wf_paths t1 t2)
 
 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
+  Array.fold_left inter_spec 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 Lazy.t 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
+let make_renv env recarg tree =
   { env = env;
-    rel_min = recarg+2;
-    inds = minds;
-    recvec = mind_recvec;
-    genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
+    rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *)
+    genv = [Lazy.lazy_from_val(Subterm(Large,tree))] }
 
 let push_var renv (x,ty,spec) =
-  { renv with
-    env = push_rel (x,None,ty) renv.env;
+  { env = push_rel (x,None,ty) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
 
 let assign_var_spec renv (i,spec) =
-  { renv with genv = list_assign renv.genv (i-1) spec }
+  { renv with genv = List.assign renv.genv (i-1) spec }
 
 let push_var_renv renv (x,ty) =
   push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
@@ -458,15 +541,13 @@ let subterm_var p renv =
 
 let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
-  { renv with
-    env = push_rel_context ctxt renv.env;
+  { env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
     genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
 
 let push_fix_renv renv (_,v,_ as recdef) =
   let n = Array.length v in
-  { renv with
-    env = push_rec_types recdef renv.env;
+  { env = push_rec_types recdef renv.env;
     rel_min = renv.rel_min+n;
     genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
 
@@ -524,14 +605,171 @@ let branches_specif renv c_spec ci =
 		Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
 		  let vra = Array.of_list (dest_subterms t).(i) in
 		  assert (nca = Array.length vra);
-		  Array.map
-		    (fun t -> Lazy.force (spec_of_tree (lazy t)))
-		    vra
-	      | Dead_code -> Array.create nca Dead_code
-	      | _ -> Array.create nca Not_subterm) in
-	 list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
+		  Array.map spec_of_tree vra
+	      | Dead_code -> Array.make nca Dead_code
+	      | _ -> Array.make nca Not_subterm) in
+	 List.init nca (fun j -> lazy (Lazy.force lvra).(j)))
       car 
 
+let check_inductive_codomain env p =
+  let absctx, ar = dest_lam_assum env p in
+  let env = push_rel_context absctx env in
+  let arctx, s = dest_prod_assum env ar in
+  let env = push_rel_context arctx env in
+  let i,l' = decompose_app (whd_betadeltaiota env s) in
+  match i with Ind _ -> true | _ -> false 
+
+(* The following functions are almost duplicated from indtypes.ml, except
+that they carry here a poorer environment (containing less information). *)
+let ienv_push_var (env, lra) (x,a,ra) =
+(push_rel (x,None,a) env, (Norec,ra)::lra)
+
+let ienv_push_inductive (env, ra_env) ((mind,u),lpar) =
+  let mib = Environ.lookup_mind mind env in
+  let ntypes = mib.mind_ntypes in
+  let push_ind specif env =
+     push_rel (Anonymous,None,
+		hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env
+  in
+  let env = Array.fold_right push_ind mib.mind_packets env in
+  let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in
+  let lra_ind = Array.rev_to_list rc in
+  let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in
+  (env, lra_ind @ ra_env)
+
+let rec ienv_decompose_prod (env,_ as ienv) n c =
+ if Int.equal n 0 then (ienv,c) else
+   let c' = whd_betadeltaiota env c in
+   match c' with
+   Prod(na,a,b) ->
+     let ienv' = ienv_push_var ienv (na,a,mk_norec) in
+     ienv_decompose_prod ienv' (n-1) b
+     | _ -> assert false
+
+let lambda_implicit_lift n a =
+  let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in
+  let implicit_sort = Sort (Type (Universe.make level)) in
+  let lambda_implicit a = Lambda (Anonymous, implicit_sort, a) in
+  iterate lambda_implicit n (lift n a)
+
+let abstract_mind_lc ntyps npars lc =
+  if Int.equal npars 0 then
+    lc
+  else
+    let make_abs =
+      List.init ntyps
+	(function i -> lambda_implicit_lift npars (Rel (i+1)))
+    in
+    Array.map (substl make_abs) lc
+
+(* [get_recargs_approx env tree ind args] builds an approximation of the recargs
+tree for ind, knowing args. The argument tree is used to know when candidate
+nested types should be traversed, pruning the tree otherwise. This code is very
+close to check_positive in indtypes.ml, but does no positivy check and does not
+compute the number of recursive arguments. *)
+let get_recargs_approx env tree ind args =
+  let rec build_recargs (env, ra_env as ienv) tree c =
+    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    match x with
+    | Prod (na,b,d) ->
+       assert (List.is_empty largs);
+       build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d
+    | Rel k ->
+       (* Free variables are allowed and assigned Norec *)
+       (try snd (List.nth ra_env (k-1))
+        with Failure _ | Invalid_argument _ -> mk_norec)
+    | Ind ind_kn ->
+       (* When the inferred tree allows it, we consider that we have a potential
+       nested inductive type *)
+       begin match dest_recarg tree with
+	     | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' ->
+			   build_recargs_nested ienv tree (ind_kn, largs)
+	     | _ -> mk_norec
+       end
+    | err ->
+       mk_norec
+
+  and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) =
+    (* If the infered tree already disallows recursion, no need to go further *)
+    if eq_wf_paths tree mk_norec then tree
+    else
+    let mib = Environ.lookup_mind mind env in
+    let auxnpar = mib.mind_nparams_rec in
+    let nonrecpar = mib.mind_nparams - auxnpar in
+    let (lpar,_) = List.chop auxnpar largs in
+    let auxntyp = mib.mind_ntypes in
+    (* Extends the environment with a variable corresponding to
+	     the inductive def *)
+    let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in
+    (* Parameters expressed in env' *)
+    let lpar' = List.map (lift auxntyp) lpar in
+    (* In case of mutual inductive types, we use the recargs tree which was
+    computed statically. This is fine because nested inductive types with
+    mutually recursive containers are not supported. *)
+    let trees =
+      if Int.equal auxntyp 1 then [|dest_subterms tree|]
+      else Array.map (fun mip -> dest_subterms mip.mind_recargs) mib.mind_packets
+    in
+    let mk_irecargs j specif =
+      (* The nested inductive type with parameters removed *)
+      let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in
+      let paths = Array.mapi
+        (fun k c ->
+	 let c' = hnf_prod_applist env' c lpar' in
+	 (* skip non-recursive parameters *)
+	 let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in
+	 build_recargs_constructors ienv' trees.(j).(k) c')
+	auxlcvect
+      in
+      mk_paths (Imbr (mind,j)) paths
+    in
+    let irecargs = Array.mapi mk_irecargs mib.mind_packets in
+    (Rtree.mk_rec irecargs).(i)
+
+  and build_recargs_constructors ienv trees c =
+    let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c =
+      let x,largs = decompose_app (whd_betadeltaiota env c) in
+	match x with
+
+          | Prod (na,b,d) ->
+	     let () = assert (List.is_empty largs) in
+             let recarg = build_recargs ienv (List.hd trees) b in
+             let ienv' = ienv_push_var ienv (na,b,mk_norec) in
+             recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d
+          | hd ->
+             List.rev lrec
+    in
+    recargs_constr_rec ienv trees [] c
+  in
+  (* starting with ra_env = [] seems safe because any unbounded Rel will be
+  assigned Norec *)
+  build_recargs_nested (env,[]) tree (ind, args)
+
+(* [restrict_spec env spec p] restricts the size information in spec to what is
+   allowed to flow through a match with predicate p in environment env. *)
+let restrict_spec env spec p =
+  if spec = Not_subterm then spec
+  else let absctx, ar = dest_lam_assum env p in
+  (* Optimization: if the predicate is not dependent, no restriction is needed
+     and we avoid building the recargs tree. *)
+  if noccur_with_meta 1 (rel_context_length absctx) ar then spec
+  else
+  let env = push_rel_context absctx env in
+  let arctx, s = dest_prod_assum env ar in
+  let env = push_rel_context arctx env in
+  let i,args = decompose_app (whd_betadeltaiota env s) in
+  match i with
+  | Ind i ->
+     begin match spec with
+	   | Dead_code -> spec
+	   | Subterm(st,tree) ->
+	      let recargs = get_recargs_approx env tree i args in
+	      let recargs = inter_wf_paths tree recargs in
+	      Subterm(st,recargs)
+	   | _ -> assert false
+     end
+  | _ -> Not_subterm
+
 (* [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
@@ -545,36 +783,40 @@ let rec subterm_specif renv stack t =
     match f with
       | Rel k -> subterm_var k renv
 
-      | Case (ci,_,c,lbr) ->
-	  let stack' = push_stack_closures renv l stack in
-          let cases_spec = branches_specif renv 
-	    (lazy_subterm_specif renv [] c) ci in
-          let stl  =
-            Array.mapi (fun i br' ->
-			  let stack_br = push_stack_args (cases_spec.(i)) stack' in
-			    subterm_specif renv stack_br br')
-              lbr in
-            subterm_spec_glb stl
-
-      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
-	  (* when proving that the fixpoint f(x)=e is less than n, it is enough
-	     to prove that e is less than n assuming f is less than n
-	     furthermore when f is applied to a term which is strictly less than
-	     n, one may assume that x itself is strictly less than n
-	  *)
-          let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
-          let oind =
-            let env' = push_rel_context ctxt renv.env in
-              try Some(fst(find_inductive env' clfix))
-              with Not_found -> None in
-            (match oind with
-		 None -> Not_subterm (* happens if fix is polymorphic *)
-               | Some ind ->
-		   let nbfix = Array.length typarray in
-		   let recargs = lookup_subterms renv.env ind in
-		     (* pushing the fixpoints *)
-		   let renv' = push_fix_renv renv recdef in
-		   let renv' =
+    | Case (ci,p,c,lbr) ->
+       let stack' = push_stack_closures renv l stack in
+       let cases_spec =
+	 branches_specif renv (lazy_subterm_specif renv [] c) ci
+       in
+       let stl =
+	 Array.mapi (fun i br' ->
+		     let stack_br = push_stack_args (cases_spec.(i)) stack' in
+		     subterm_specif renv stack_br br')
+		    lbr in
+       let spec = subterm_spec_glb stl in
+       restrict_spec renv.env spec p
+
+    | 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
+      *)
+    if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm
+    else 
+      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'
@@ -618,9 +860,10 @@ and extract_stack renv a = function
 
 
 (* Check size x is a correct size for recursive calls. *)
-let check_is_subterm x =
+let check_is_subterm x tree =
   match Lazy.force x with
-    Subterm (Strict,_) | Dead_code -> true
+  | Subterm (Strict,tree') -> incl_wf_paths tree tree'
+  | Dead_code -> true
   |  _ -> false
 
 (************************************************************************)
@@ -643,10 +886,38 @@ let error_illegal_rec_call renv fx (arg_renv,arg) =
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
 
+let filter_stack_domain env ci p stack =
+  let absctx, ar = dest_lam_assum env p in
+  (* Optimization: if the predicate is not dependent, no restriction is needed
+     and we avoid building the recargs tree. *)
+  if noccur_with_meta 1 (rel_context_length absctx) ar then stack
+  else let env = push_rel_context absctx env in
+  let rec filter_stack env ar stack =
+    let t = whd_betadeltaiota env ar in
+    match stack, t with
+    | elt :: stack', Prod (n,a,c0) ->
+      let d = (n,None,a) in
+      let ty, args = decompose_app (whd_betadeltaiota env a) in
+      let elt = match ty with
+      | Ind ind -> 
+        let spec' = stack_element_specif elt in
+        (match (Lazy.force spec') with
+        | Not_subterm | Dead_code -> elt
+        | Subterm(s,path) ->
+            let recargs = get_recargs_approx env path ind args in
+            let path = inter_wf_paths path recargs in
+            SArg (lazy (Subterm(s,path))))
+      | _ -> (SArg (lazy Not_subterm))
+      in
+      elt :: filter_stack (push_rel d env) c0 stack'
+    | _,_ -> List.fold_right (fun _ l -> SArg (lazy Not_subterm) :: l) stack []
+  in
+  filter_stack env ar stack
+
 (* 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 check_one_fix renv recpos trees def =
   let nfi = Array.length recpos in
 
   (* Checks if [t] only make valid recursive calls *)
@@ -658,7 +929,7 @@ let check_one_fix renv recpos def =
       match f with
         | Rel p ->
             (* Test if [p] is a fixpoint (recursive call) *)
-	    if renv.rel_min <= p & p < renv.rel_min+nfi then
+	    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: *)
@@ -668,9 +939,10 @@ let check_one_fix renv recpos def =
 		let stack' = push_stack_closures renv l stack in
                 if List.length stack' <= np then error_partial_apply renv glob
                 else
+		  (* Retrieve the expected tree for the argument *)
                   (* Check the decreasing arg is smaller *)
                   let z = List.nth stack' np in
-	          if not (check_is_subterm (stack_element_specif z)) then
+	          if not (check_is_subterm (stack_element_specif z) trees.(glob)) then
                     begin match z with
 		      |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') 
 		      |SArg _ -> error_partial_apply renv glob
@@ -694,6 +966,7 @@ let check_one_fix renv recpos def =
             let case_spec = branches_specif renv 
 	      (lazy_subterm_specif renv [] c_0) ci in
 	    let stack' = push_stack_closures renv l stack in
+        let stack' = filter_stack_domain renv.env ci p stack' in
               Array.iteri (fun k br' -> 
 			     let stack_br = push_stack_args case_spec.(k) stack' in
 			     check_rec_call renv stack_br br') lrest
@@ -725,11 +998,11 @@ let check_one_fix renv recpos def =
                    else check_rec_call renv' [] body)
                 bodies
 
-        | Const kn ->
+        | Const (kn,u) ->
             if evaluable_constant kn renv.env then
               try List.iter (check_rec_call renv []) l
               with (FixGuardError _ ) ->
-		let value = (applist(constant_value renv.env kn, l)) in
+		let value = (applist(constant_value renv.env (kn,u), l)) in
 	        check_rec_call renv stack value
 	    else List.iter (check_rec_call renv []) l
 
@@ -753,16 +1026,7 @@ let check_one_fix renv recpos def =
         | (Ind _ | Construct _) ->
             List.iter (check_rec_call renv []) l
 
-        | Var id ->
-            begin
-              match pi2 (lookup_named id renv.env) with
-              | None ->
-                  List.iter (check_rec_call renv []) l
-              | Some c ->
-                  try List.iter (check_rec_call renv []) l
-                  with (FixGuardError _) -> 
-		    check_rec_call renv stack (applist(c,l))
-            end
+        | Var _ -> anomaly (Pp.str "Section variable in Coqchk !")
 
 	| Sort _ -> assert (l = [])
 
@@ -771,6 +1035,8 @@ let check_one_fix renv recpos def =
 
         | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
 
+	| Proj (p, c) -> check_rec_call renv [] c
+
   and check_nested_fix_body renv decr recArgsDecrArg body =
     if decr = 0 then
       check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
@@ -780,7 +1046,7 @@ let check_one_fix renv recpos def =
 	    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"
+	| _ -> anomaly (Pp.str "Not enough abstractions in fix body")
 	    
   in
   check_rec_call renv [] def
@@ -789,12 +1055,12 @@ let check_one_fix renv recpos 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";
+    || Array.length nvect <> nbfix
+    || Array.length types <> nbfix
+    || Array.length names <> nbfix
+    || bodynum < 0
+    || bodynum >= nbfix
+  then anomaly (Pp.str "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
@@ -815,20 +1081,25 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
 		    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"
+            else anomaly ~label:"check_one_fix" (Pp.str "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
+  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
+  let get_tree (kn,i) =
+    let mib = Environ.lookup_mind kn env in
+    mib.mind_packets.(i).mind_recargs
+  in
+  let trees = Array.map get_tree minds 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
+    let renv = make_renv fenv nvect.(i) trees.(i) in
+    try check_one_fix renv nvect trees body
     with FixGuardError (fixenv,err) ->
       error_ill_formed_rec_body fixenv err names i
   done
@@ -844,7 +1115,7 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;;
 exception CoFixGuardError of env * guard_error
 
 let anomaly_ill_typed () =
-  anomaly "check_one_cofix: too many arguments applied to constructor"
+  anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor")
 
 let rec codomain_is_coind env c =
   let b = whd_betadeltaiota env c in
@@ -857,7 +1128,7 @@ let rec codomain_is_coind env c =
 	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
 
 let check_one_cofix env nbfix def deftype =
-  let rec check_rec_call env alreadygrd n vlra  t =
+  let rec check_rec_call env alreadygrd n tree vlra  t =
     if not (noccur_with_meta n nbfix t) then
       let c,args = decompose_app (whd_betadeltaiota env t) in
       match c with
@@ -868,12 +1139,11 @@ let check_one_cofix env nbfix def deftype =
 	      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)  ->
+	| Construct ((_,i as cstr_kn),u)  ->
             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 realargs = List.skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
               | (t::lr), (rar::lrar) ->
                   if rar = mk_norec then
@@ -881,10 +1151,10 @@ let check_one_cofix env nbfix def deftype =
                     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)
+                  else begin
+                      check_rec_call env true n rar (dest_subterms rar) t;
+                      process_args_of_constr (lr, lrar)
+		    end
               | [],_ -> ()
               | _ -> anomaly_ill_typed ()
             in process_args_of_constr (realargs, lra)
@@ -893,44 +1163,52 @@ let check_one_cofix env nbfix def deftype =
 	     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
+              check_rec_call env' alreadygrd (n+1) tree 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
-	      if array_for_all (noccur_with_meta n nbfix) varit then
+	      if Array.for_all (noccur_with_meta n nbfix) varit then
 		let nbfix = Array.length vdefs in
 		let env' = push_rec_types recdef env in
-		(Array.iter (check_rec_call env' alreadygrd (n+nbfix) vlra) vdefs;
-		 List.iter (check_rec_call env alreadygrd n vlra) args)
+		(Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs;
+		 List.iter (check_rec_call env alreadygrd n tree 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))
+	   begin
+	     let tree = match restrict_spec env (Subterm (Strict, tree)) p with
+	     | Dead_code -> assert false
+	     | Subterm (_, tree') -> tree'
+	     | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c))
+	     in
+               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
+		     let vlra = dest_subterms tree in
+		     Array.iter (check_rec_call env alreadygrd n tree vlra) vrest
+		   else
+		     raise (CoFixGuardError (env,RecCallInCaseFun c))
+		 else
+		   raise (CoFixGuardError (env,RecCallInCaseArg c))
+               else
+		 raise (CoFixGuardError (env,RecCallInCasePred c))
+	   end
 
 	| Meta _ -> ()
         | Evar _ ->
-	    List.iter (check_rec_call env alreadygrd n vlra) args
+	    List.iter (check_rec_call env alreadygrd n tree 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
+  check_rec_call env false 1 vlra (dest_subterms vlra) def
 
 (* The  function which checks that the whole block of definitions
    satisfies the guarded condition *)
diff --git a/checker/inductive.mli b/checker/inductive.mli
index 0c1117f5..78fb0bdd 100644
--- a/checker/inductive.mli
+++ b/checker/inductive.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,14 +8,13 @@
 
 (*i*)
 open Names
-open Term
-open Declarations
+open Cic
 open Environ
 (*i*)
 
 (*s Extracting an inductive type from a construction *)
 
-val find_rectype : env -> constr -> inductive * constr list
+val find_rectype : env -> constr -> pinductive * constr list
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
@@ -23,12 +22,14 @@ type mind_specif = mutual_inductive_body * one_inductive_body
     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
+val inductive_instance : mutual_inductive_body -> Univ.universe_instance
+
+val type_of_inductive : env -> mind_specif puniverses -> constr
 
 (* Return type as quoted by the user *)
-val type_of_constructor : constructor -> mind_specif -> constr
+val type_of_constructor : pconstructor -> mind_specif -> constr
 
-val arities_of_specif : mutual_inductive -> mind_specif -> constr array
+val arities_of_specif : mutual_inductive puniverses -> mind_specif -> constr array
 
 (* [type_case_branches env (I,args) (p:A) c] computes useful types
    about the following Cases expression:
@@ -37,7 +38,7 @@ val arities_of_specif : mutual_inductive -> mind_specif -> constr array
    introduced by products) and the type for the whole expression.
  *)
 val type_case_branches :
-  env -> inductive * constr list -> constr * constr -> constr
+  env -> pinductive * constr list -> constr * constr -> constr
     -> constr array * constr
 
 (* Check a [case_info] actually correspond to a Case expression on the
@@ -51,12 +52,12 @@ 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
+  env -> mind_specif puniverses -> constr array -> constr
 
 val max_inductive_sort : sorts array -> Univ.universe
 
 val instantiate_universes : env -> rel_context ->
-    polymorphic_arity -> constr array -> rel_context * sorts
+  template_arity -> constr array -> rel_context * sorts
 
 (***************************************************************)
 (* Debug *)
@@ -70,10 +71,6 @@ type guard_env =
   { env     : env;
     (* dB of last fixpoint *)
     rel_min : int;
-    (* inductive of recarg of each fixpoint *)
-    inds    : inductive array;
-    (* the recarg information of inductive family *)
-    recvec  : wf_paths array;
     (* dB of variables denoting subterms *)
     genv    : subterm_spec Lazy.t list;
   }
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
index dc3ed452..998e23c6 100644
--- a/checker/mod_checking.ml
+++ b/checker/mod_checking.ml
@@ -2,8 +2,8 @@
 open Pp
 open Util
 open Names
+open Cic
 open Term
-open Inductive
 open Reduction
 open Typeops
 open Indtypes
@@ -12,371 +12,132 @@ open Subtyping
 open Declarations
 open Environ
 
-(************************************************************************)
-(* Checking constants *)
+(** {6 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.empty_constraint
+        let u' = Univ.Universe.make (Univ.Level.make empty_dirpath 1) in
+        mkArity (ctxt,Prop Null), 
+	  Univ.enforce_leq u u' Univ.empty_constraint
     | _ -> ar, Univ.empty_constraint
 
 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
+  Flags.if_verbose ppnl (str "  checking cst: " ++ prcon kn); pp_flush ();
+  let env' = add_constraints (Univ.UContext.constraints cb.const_universes) env in
+  let envty, ty = 
+    match cb.const_type with
+      RegularArity ty ->
+        let ty', cu = refresh_arity ty in
         let envty = add_constraints cu env' in
-        let _ = infer_type envty ty in
-        (match body_of_constant cb with
-          | Some bd ->
-              let j = infer env' (force_constr bd) in
-              conv_leq envty j ty
-          | None -> ())
-    | PolymorphicArity(ctxt,par) ->
-        let _ = check_ctxt env ctxt in
-        check_polymorphic_arity env ctxt par);
-  add_constant kn cb env
-
-(************************************************************************)
-(* Checking modules *)
-
-
-exception Not_path
-
-let path_of_mexpr = function
-  | SEBident mp -> mp
-  | _ -> raise Not_path
-
-let is_modular = function
-  | SFBmodule _ | SFBmodtype _ -> true
-  | SFBconst _ | SFBmind _ -> false
-
-let rec list_split_assoc ((k,m) as km) rev_before = function
-  | [] -> raise Not_found
-  | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
-  | h::tail -> list_split_assoc km (h::rev_before) tail
-
-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
+        let _ = infer_type envty ty' in envty, ty
+    | TemplateArity(ctxt,par) ->
+        let _ = check_ctxt env' ctxt in
+        check_polymorphic_arity env' ctxt par;
+	env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt 
+  in
+  let () = 
+    match body_of_constant cb with
+    | Some bd ->
+      (match cb.const_proj with 
+      | None -> let j = infer envty bd in
+		  conv_leq envty j ty
+      | Some pb -> 
+	let env' = add_constant kn cb env' in
+	let j = infer env' bd in
+	  conv_leq envty j ty)
+    | None -> ()
   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;
-  (* In the spirit of subtyping.check_constant, we accept
-     any implementations of parameters and opaques terms,
-     as long as they have the right type *)
-  (match cb2.const_body with
-    | Undef _ | OpaqueDef _ -> ()
-    | Def lc2 ->
-	(match cb1.const_body with
-	  | Def lc1 ->
-	    let c1 = force_constr lc1 in
-            let c2 = force_constr lc2 in
-	    Reduction.conv env c1 c2
-	  (* Coq only places transparent cb in With_definition_body *)
-	  | _ -> assert false))
+  if cb.const_polymorphic then add_constant kn cb env
+  else add_constant kn cb env'
 
-let lookup_modtype mp env =
-  try Environ.lookup_modtype mp env
-  with Not_found ->
-    failwith ("Unknown module type: "^string_of_mp mp)
+(** {6 Checking modules } *)
+
+(** We currently ignore the [mod_type_alg] and [typ_expr_alg] fields.
+    The only delicate part is when [mod_expr] is an algebraic expression :
+    we need to expand it before checking it is indeed a subtype of [mod_type].
+    Fortunately, [mod_expr] cannot contain any [MEwith]. *)
 
 let lookup_module mp env =
   try Environ.lookup_module mp env
   with Not_found ->
     failwith ("Unknown module: "^string_of_mp mp)
 
-let rec check_with env mtb with_decl mp=
-  match with_decl with
-    | With_definition_body (idl,c) ->
-	check_with_def env mtb (idl,c) mp;
-	mtb
-    | With_module_body (idl,mp1) ->
-	check_with_mod env mtb (idl,mp1) mp;
-	mtb
-
-and check_with_def env mtb (idl,c) mp =
-  let sig_b = match mtb with
-    | SEBstruct(sig_b) ->
-	sig_b
-    | _ -> error_signature_expected mtb
-  in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
+let mk_mtb mp sign delta =
+  { mod_mp = mp;
+    mod_expr = Abstract;
+    mod_type = sign;
+    mod_type_alg = None;
+    mod_constraints = Univ.Constraint.empty;
+    mod_delta = delta;
+    mod_retroknowledge = []; }
+
+let rec check_module env mp mb =
+  let (_:module_signature) =
+    check_signature env mb.mod_type mb.mod_mp mb.mod_delta
   in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
-      let before = List.rev rev_before in
-      let env' = Modops.add_signature mp before empty_delta_resolver env in
-      if idl = [] then
-	      let cb = match spec with
-		  SFBconst cb -> cb
-		| _ -> error_not_a_constant l
-	      in
-              check_definition_sub env' c cb
-      else
-	      let old = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module l
-	      in
-		begin
-		  match old.mod_expr with
-                    | None ->
-		        check_with_def env' old.mod_type (idl,c) (MPdot(mp,l))
-                    | Some msb ->
-			error_a_generative_module_expected l
-		end
-    with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
-
-and check_with_mod env mtb (idl,mp1) mp =
-  let sig_b =
-    match mtb with
-    | SEBstruct(sig_b) ->
-	sig_b
-    | _ -> error_signature_expected mtb in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
+  let optsign = match mb.mod_expr with
+    |Struct sign -> Some (check_signature env sign mb.mod_mp mb.mod_delta)
+    |Algebraic me -> Some (check_mexpression env me mb.mod_mp mb.mod_delta)
+    |Abstract|FullStruct -> None
   in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in
-      let before = List.rev rev_before in
-      let env' = Modops.add_signature mp before empty_delta_resolver env in
-      if idl = [] then
-	      let _ = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module l
-	      in
-	      let (_:module_body) = (Environ.lookup_module mp1 env) in ()
-      else
-	    let old = match spec with
-		SFBmodule msb -> msb
-	      | _ -> error_not_a_module l
-	    in
-	      begin
-		match old.mod_expr with
-                    None ->
-		      check_with_mod env'
-			  old.mod_type (idl,mp1) (MPdot(mp,l))
-                  | Some msb ->
-                      error_a_generative_module_expected l
-              end
-    with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
+  match optsign with
+  |None -> ()
+  |Some sign ->
+    let mtb1 = mk_mtb mp sign mb.mod_delta
+    and mtb2 = mk_mtb mp mb.mod_type mb.mod_delta in
+    let env = add_module_type mp mtb1 env in
+    Subtyping.check_subtypes env mtb1 mtb2
 
 and check_module_type env mty =
-  let (_:struct_expr_body) =
-    check_modtype env mty.typ_expr mty.typ_mp mty.typ_delta in
+  let (_:module_signature) =
+    check_signature env mty.mod_type mty.mod_mp mty.mod_delta in
   ()
 
-							 
-and check_module env mp mb =
-  match mb.mod_expr, mb.mod_type with
-    | None,mtb -> 
-	let (_:struct_expr_body) =
-	  check_modtype env mtb mb.mod_mp mb.mod_delta in ()
-    | Some mexpr, mtb when mtb==mexpr ->
-	let (_:struct_expr_body) =
-	  check_modtype env mtb mb.mod_mp mb.mod_delta in ()
-    | Some mexpr, _ ->
-	let sign = check_modexpr env mexpr mb.mod_mp mb.mod_delta in
-	let (_:struct_expr_body) =
-	  check_modtype env mb.mod_type mb.mod_mp mb.mod_delta in
-	let mtb1 =
-	  {typ_mp=mp;
-	   typ_expr=sign;
-	   typ_expr_alg=None;
-	   typ_constraints=Univ.empty_constraint;
-	   typ_delta = mb.mod_delta;}
-	and mtb2 =
-	  {typ_mp=mp;
-	   typ_expr=mb.mod_type;
-	   typ_expr_alg=None;
-	   typ_constraints=Univ.empty_constraint;
-	   typ_delta = mb.mod_delta;}
-	in
-	let env = add_module (module_body_of_type mp mtb1) env in
-	check_subtypes env mtb1 mtb2
-
 and check_structure_field env mp lab res = function
   | SFBconst cb ->
-      let c = make_con mp empty_dirpath lab in
-	check_constant_declaration env c cb
+      let c = Constant.make2 mp lab in
+      check_constant_declaration env c cb
   | SFBmind mib ->
-      let kn = make_mind mp empty_dirpath lab in
+      let kn = MutInd.make2 mp lab in
       let kn = mind_of_delta res kn in
-	Indtypes.check_inductive env kn mib
+      Indtypes.check_inductive env kn mib
   | SFBmodule msb ->
-      let (_:unit) = check_module env (MPdot(mp,lab)) msb in
-	Modops.add_module msb env
+      let () = check_module env (MPdot(mp,lab)) msb in
+      Modops.add_module msb env
   | SFBmodtype mty ->
       check_module_type env mty;
       add_modtype (MPdot(mp,lab)) mty env
-	
-and check_modexpr env mse mp_mse res = match mse with
-  | SEBident mp ->
+
+and check_mexpr env mse mp_mse res = match mse with
+  | MEident mp ->
       let mb = lookup_module mp env in
       (subst_and_strengthen mb mp_mse).mod_type
-  | SEBfunctor (arg_id, mtb, body) ->
-      check_module_type env mtb ;
-      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
-      let sign = check_modexpr env' body mp_mse res in
-	SEBfunctor (arg_id, mtb, sign)
-  | SEBapply (f,m,cst) ->
-      let sign = check_modexpr env f mp_mse res in
-      let farg_id, farg_b, fbody_b = destr_functor env sign in
-      let mp =
-	try (path_of_mexpr m)
-	with Not_path -> error_application_to_not_path m
-	  (* place for nondep_supertype *) in
+  | MEapply (f,mp) ->
+      let sign = check_mexpr env f mp_mse res in
+      let farg_id, farg_b, fbody_b = destr_functor sign in
       let mtb = module_type_of_module (Some mp) (lookup_module mp env) in
-	check_subtypes env mtb farg_b;
-	(subst_struct_expr (map_mbid farg_id mp) fbody_b)
-  | SEBwith(mte, with_decl) ->
-      let sign = check_modexpr env mte mp_mse res in
-      let sign = check_with env sign with_decl mp_mse in 
-	sign
-  | SEBstruct(msb) ->
-      let (_:env) = List.fold_left (fun env (lab,mb) ->
-		   check_structure_field env mp_mse lab res mb) env msb in
-	SEBstruct(msb)
-	
-and check_modtype env mse mp_mse res = match mse with
-  | SEBident mp ->
-      let mtb = lookup_modtype mp env in
-	mtb.typ_expr
-  | SEBfunctor (arg_id, mtb, body) ->
-      check_module_type env mtb;
-      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
-      let body = check_modtype env' body mp_mse res in
-	SEBfunctor(arg_id,mtb,body)
-  | SEBapply (f,m,cst) ->
-      let sign = check_modtype env f mp_mse res in
-      let farg_id, farg_b, fbody_b = destr_functor env sign in
-      let mp =
-	try (path_of_mexpr m)
-	with Not_path -> error_application_to_not_path m
-	  (* place for nondep_supertype *) in
-      let mtb = module_type_of_module (Some mp) (lookup_module mp env) in
-	check_subtypes env mtb farg_b;
-	subst_struct_expr (map_mbid farg_id mp) fbody_b
-  | SEBwith(mte, with_decl) ->
-      let sign = check_modtype env mte mp_mse res in
-      let sign = check_with env sign with_decl mp_mse in
-	sign
-  | SEBstruct(msb) ->
-      let (_:env) = List.fold_left (fun env (lab,mb) ->
-		   check_structure_field env mp_mse lab res mb) env msb in
-      SEBstruct(msb)
-	
-(*
-  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
+      check_subtypes env mtb farg_b;
+      subst_signature (map_mbid farg_id mp) fbody_b
+  | MEwith _ -> error_with_module ()
 
-  | 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 check_mexpression env sign mp_mse res = match sign with
+  | MoreFunctor (arg_id, mtb, body) ->
+      check_module_type env mtb;
+      let env' = add_module_type (MPbound arg_id) mtb env in
+      let body = check_mexpression env' body mp_mse res in
+      MoreFunctor(arg_id,mtb,body)
+  | NoFunctor me -> check_mexpr env me mp_mse res
 
-and add_modtype_constraints env mtb =
-  add_struct_expr_constraints env mtb.typ_expr
-*)
+and check_signature env sign mp_mse res = match sign with
+  | MoreFunctor (arg_id, mtb, body) ->
+      check_module_type env mtb;
+      let env' = add_module_type (MPbound arg_id) mtb env in
+      let body = check_signature env' body mp_mse res in
+      MoreFunctor(arg_id,mtb,body)
+  | NoFunctor struc ->
+      let (_:env) = List.fold_left (fun env (lab,mb) ->
+	check_structure_field env mp_mse lab res mb) env struc
+      in
+      NoFunctor struc
diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli
index e2f63b77..ae28caed 100644
--- a/checker/mod_checking.mli
+++ b/checker/mod_checking.mli
@@ -1,9 +1,9 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-val check_module : Environ.env -> Names.module_path -> Declarations.module_body -> unit
+val check_module : Environ.env -> Names.module_path -> Cic.module_body -> unit
diff --git a/checker/modops.ml b/checker/modops.ml
index 11793af9..8ccf118d 100644
--- a/checker/modops.ml
+++ b/checker/modops.ml
@@ -1,126 +1,111 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
+open Errors
 open Util
 open Pp
 open Names
-open Univ
-open Term
+open Cic
 open Declarations
-open Environ
 (*i*)
 
 let error_not_a_constant l =
-  error ("\""^(string_of_label l)^"\" is not a constant")
+  error ("\""^(Label.to_string l)^"\" is not a constant")
 
-let error_not_a_functor _ = error "Application of not a functor"
+let error_not_a_functor () = error "Application of not a functor"
 
 let error_incompatible_modtypes _ _ = error "Incompatible module types"
 
 let error_not_match l _ =
-  error ("Signature components for label "^string_of_label l^" do not match")
+  error ("Signature components for label "^Label.to_string l^" do not match")
 
-let error_no_such_label l = error ("No such label "^string_of_label l)
+let error_no_such_label l = error ("No such label "^Label.to_string l)
 
 let error_no_such_label_sub l l1 =
   let l1 = string_of_mp l1 in
   error ("The field "^
-         string_of_label l^" is missing in "^l1^".")
+         Label.to_string l^" is missing in "^l1^".")
 
 let error_not_a_module_loc loc s =
-  user_err_loc (loc,"",str ("\""^string_of_label s^"\" is not a module"))
+  user_err_loc (loc,"",str ("\""^Label.to_string s^"\" is not a module"))
 
-let error_not_a_module s = error_not_a_module_loc dummy_loc s
+let error_not_a_module s = error_not_a_module_loc Loc.ghost s
 
-let error_with_incorrect l =
-  error ("Incorrect constraint for label \""^(string_of_label l)^"\"")
+let error_with_module () =
+  error "Unsupported 'with' constraint in module implementation"
 
-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 is_functor = function
+  | MoreFunctor _ -> true
+  | NoFunctor _ -> false
 
-let error_signature_expected mtb =
-  error "Signature expected"
+let destr_functor = function
+  | MoreFunctor (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
+  | NoFunctor _ -> error_not_a_functor ()
 
-let error_application_to_not_path _ = error "Application to not path"
+let module_body_of_type mp mtb =
+  { mtb with mod_mp = mp; mod_expr = Abstract }
 
-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 module_body_of_type mp mtb = 
-  { mod_mp = mp;
-    mod_type = mtb.typ_expr;
-    mod_type_alg = mtb.typ_expr_alg;
-    mod_expr = None;
-    mod_constraints = mtb.typ_constraints;
-    mod_delta = mtb.typ_delta;
-    mod_retroknowledge = []}
-
-let rec add_signature mp sign resolver env = 
+let rec add_structure mp sign resolver env =
   let add_one env (l,elem) =
-    let kn = make_kn mp empty_dirpath l in
-    let con = constant_of_kn kn in
-    let mind = mind_of_delta resolver (mind_of_kn kn) in
+    let kn = KerName.make2 mp l in
+    let con = Constant.make1 kn in
+    let mind = mind_of_delta resolver (MutInd.make1 kn) in
       match elem with
-	| SFBconst cb -> 
+	| SFBconst cb ->
 	   (* let con =  constant_of_delta resolver con in*)
 	      Environ.add_constant con cb env
-	| SFBmind mib -> 
+	| SFBmind mib ->
 	   (* let mind =  mind_of_delta resolver mind in*)
 	    Environ.add_mind mind mib env
 	| SFBmodule mb -> add_module mb env
 	      (* adds components as well *)
-	| SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+	| SFBmodtype mtb -> Environ.add_modtype mtb.mod_mp mtb env
   in
-    List.fold_left add_one env sign
+  List.fold_left add_one env sign
 
-and add_module mb env = 
+and add_module mb env =
   let mp = mb.mod_mp in
   let env = Environ.shallow_add_module mp mb env in
-    match mb.mod_type with
-      | SEBstruct (sign) -> 
-	    add_signature mp sign mb.mod_delta env
-      | SEBfunctor _ -> env
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
+  match mb.mod_type with
+  | NoFunctor struc -> add_structure mp struc mb.mod_delta env
+  | MoreFunctor _ -> env
 
+let add_module_type mp mtb env = add_module (module_body_of_type mp mtb) env
 
 let strengthen_const mp_from l cb resolver =
   match cb.const_body with
     | Def _ -> cb
     | _ ->
-      let con = make_con mp_from empty_dirpath l in
+      let con = Constant.make2 mp_from l in
       (* let con =  constant_of_delta resolver con in*)
-      { cb with const_body = Def (Declarations.from_val (Const con)) }
+      let u = 
+	if cb.const_polymorphic then Univ.UContext.instance cb.const_universes 
+	else Univ.Instance.empty
+      in
+      { cb with const_body = Def (Declarations.from_val (Const (con,u))) }
 
 let rec strengthen_mod mp_from mp_to mb =
-  if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then
-    mb
-  else
-    match mb.mod_type with
-     | SEBstruct (sign) -> 
-	 let resolve_out,sign_out = 
-	   strengthen_sig mp_from sign mp_to mb.mod_delta in
-	   { mb with
-	       mod_expr = Some (SEBident mp_to);
-	       mod_type = SEBstruct(sign_out);
-	       mod_type_alg = mb.mod_type_alg;
-	       mod_constraints = mb.mod_constraints;
-	       mod_delta = resolve_out(*add_mp_delta_resolver mp_from mp_to 
-	       (add_delta_resolver mb.mod_delta resolve_out)*);
-	       mod_retroknowledge = mb.mod_retroknowledge}
-     | SEBfunctor _ -> mb
-     | _ -> anomaly "Modops:the evaluation of the structure failed "
-	 
+  if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb
+  else strengthen_body true mp_from mp_to mb
+
+and strengthen_body is_mod mp_from mp_to mb =
+  match mb.mod_type with
+  | MoreFunctor _ -> mb
+  | NoFunctor sign ->
+    let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta
+    in
+    { mb with
+      mod_expr =
+        (if is_mod then Algebraic (NoFunctor (MEident mp_to)) else Abstract);
+      mod_type = NoFunctor sign_out;
+      mod_delta = resolve_out }
+
 and strengthen_sig mp_from sign mp_to resolver =
   match sign with
     | [] -> empty_delta_resolver,[]
@@ -139,39 +124,23 @@ and strengthen_sig mp_from sign mp_to resolver =
 	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
 	resolve_out (*add_delta_resolver resolve_out mb.mod_delta*),
 	item':: rest'
-    | (l,SFBmodtype mty as item) :: rest -> 
+    | (l,SFBmodtype mty as item) :: rest ->
 	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
 	resolve_out,item::rest'
 
 let strengthen mtb mp =
-    match mtb.typ_expr with
-      | SEBstruct (sign) -> 
-	  let resolve_out,sign_out =
-	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
-	    {mtb with
-	       typ_expr = SEBstruct(sign_out);
-	       typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta
-		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)}
-      | SEBfunctor _ -> mtb
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
+  strengthen_body false mtb.mod_mp mp mtb
 
 let subst_and_strengthen mb mp =
   strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb)
 
-
 let module_type_of_module mp mb =
+  let mtb =
+    { mb with
+      mod_expr = Abstract;
+      mod_type_alg = None;
+      mod_retroknowledge = [] }
+  in
   match mp with
-      Some mp ->
-	strengthen {
-	  typ_mp = mp;
-	  typ_expr = mb.mod_type;
-	  typ_expr_alg = None;
-	  typ_constraints = mb.mod_constraints;
-	  typ_delta = mb.mod_delta} mp
-	  
-    | None ->
-	{typ_mp = mb.mod_mp;
-	 typ_expr = mb.mod_type;
-	 typ_expr_alg = None;
-	 typ_constraints = mb.mod_constraints;
-	 typ_delta = mb.mod_delta}
+  | Some mp -> strengthen {mtb with mod_mp = mp} mp
+  | None -> mtb
diff --git a/checker/modops.mli b/checker/modops.mli
index 61b2c80f..e22c2656 100644
--- a/checker/modops.mli
+++ b/checker/modops.mli
@@ -1,36 +1,31 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Util
 open Names
-open Univ
-open Term
-open Declarations
+open Cic
 open Environ
 (*i*)
 
 (* Various operations on modules and module types *)
 
-(* make the envirconment entry out of type *)
-val module_body_of_type : module_path -> module_type_body -> module_body
+val module_type_of_module :
+  module_path option -> module_body -> module_type_body
 
-val module_type_of_module : module_path option -> module_body ->
-  module_type_body
+val is_functor : ('ty,'a) functorize -> bool
 
-val destr_functor :
-  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
-
-val add_signature : module_path -> structure_body -> delta_resolver -> env -> env
+val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize
 
 (* adds a module and its components, but not the constraints *)
 val add_module : module_body ->  env -> env
 
+val add_module_type : module_path -> module_type_body -> env -> env
+
 val strengthen : module_type_body -> module_path -> module_type_body
 
 val subst_and_strengthen : module_body -> module_path -> module_body
@@ -40,19 +35,13 @@ val error_incompatible_modtypes :
 
 val error_not_match : label -> structure_field_body -> 'a
 
-val error_with_incorrect : label -> 'a
+val error_with_module : unit -> 'a
 
 val error_no_such_label : label -> 'a
 
 val error_no_such_label_sub :
   label -> module_path -> '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/print.ml b/checker/print.ml
new file mode 100644
index 00000000..1cc48ff7
--- /dev/null
+++ b/checker/print.ml
@@ -0,0 +1,144 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Format
+open Cic
+open Names
+
+let print_instance i = Pp.pp (Univ.Instance.pr i)
+
+let print_pure_constr csr =
+  let rec term_display c = match  c with
+  | Rel n -> print_string "#"; print_int n
+  | Meta n -> print_string "Meta("; print_int n; print_string ")"
+  | Var id -> print_string (Id.to_string id)
+  | Sort s -> sort_display s
+  | Cast (c,_, t) -> open_hovbox 1;
+      print_string "("; (term_display c); print_cut();
+      print_string "::"; (term_display t); print_string ")"; close_box()
+  | Prod (Name(id),t,c) ->
+      open_hovbox 1;
+      print_string"("; print_string (Id.to_string id);
+      print_string ":"; box_display t;
+      print_string ")"; print_cut();
+      box_display c; close_box()
+  | Prod (Anonymous,t,c) ->
+      print_string"("; box_display t; print_cut(); print_string "->";
+      box_display c; print_string ")";
+  | Lambda (na,t,c) ->
+      print_string "["; name_display na;
+      print_string ":"; box_display t; print_string "]";
+      print_cut(); box_display c;
+  | LetIn (na,b,t,c) ->
+      print_string "["; name_display na; print_string "=";
+      box_display b; print_cut();
+      print_string ":"; box_display t; print_string "]";
+      print_cut(); box_display c;
+  | App (c,l) ->
+      print_string "(";
+      box_display c;
+      Array.iter (fun x -> print_space (); box_display x) l;
+      print_string ")"
+  | Evar _ -> print_string "Evar#"
+  | Const (c,u) -> print_string "Cons(";
+      sp_con_display c;
+      print_string ","; print_instance u;
+      print_string ")"
+  | Ind ((sp,i),u) ->
+      print_string "Ind(";
+      sp_display sp;
+      print_string ","; print_int i;
+      print_string ","; print_instance u;
+      print_string ")"
+  | Construct (((sp,i),j),u) ->
+      print_string "Constr(";
+      sp_display sp;
+      print_string ",";
+      print_int i; print_string ","; print_int j; 
+      print_string ","; print_instance u; print_string ")"
+  | Case (ci,p,c,bl) ->
+      open_vbox 0;
+      print_string "<"; box_display p; print_string ">";
+      print_cut(); print_string "Case";
+      print_space(); box_display c; print_space (); print_string "of";
+      open_vbox 0;
+      Array.iter (fun x ->  print_cut();  box_display x) bl;
+      close_box();
+      print_cut();
+      print_string "end";
+      close_box()
+  | Fix ((t,i),(lna,tl,bl)) ->
+      print_string "Fix("; print_int i; print_string ")";
+      print_cut();
+      open_vbox 0;
+      let print_fix () =
+        for k = 0 to (Array.length tl) - 1 do
+	  open_vbox 0;
+	  name_display lna.(k); print_string "/";
+	  print_int t.(k); print_cut(); print_string ":";
+	  box_display tl.(k) ; print_cut(); print_string ":=";
+	  box_display bl.(k); close_box ();
+	  print_cut()
+        done
+      in print_string"{"; print_fix(); print_string"}"
+  | CoFix(i,(lna,tl,bl)) ->
+      print_string "CoFix("; print_int i; print_string ")";
+      print_cut();
+      open_vbox 0;
+      let print_fix () =
+        for k = 0 to (Array.length tl) - 1 do
+          open_vbox 1;
+	  name_display lna.(k);  print_cut(); print_string ":";
+	  box_display tl.(k) ; print_cut(); print_string ":=";
+	  box_display bl.(k); close_box ();
+	  print_cut();
+        done
+      in print_string"{"; print_fix (); print_string"}"
+  | Proj (p, c) ->
+    print_string "Proj("; sp_con_display p; print_string ","; 
+    box_display c; print_string ")"
+
+  and box_display c = open_hovbox 1; term_display c; close_box()
+
+  and sort_display = function
+    | Prop(Pos) -> print_string "Set"
+    | Prop(Null) -> print_string "Prop"
+    | Type u -> print_string "Type("; Pp.pp (Univ.pr_uni u); print_string ")"
+
+  and name_display = function
+    | Name id -> print_string (Id.to_string id)
+    | Anonymous -> print_string "_"
+(* Remove the top names for library and Scratch to avoid long names *)
+  and sp_display sp =
+(*    let dir,l = decode_kn sp in
+    let ls =
+      match List.rev_map Id.to_string (DirPath.repr dir) with
+          ("Top"::l)-> l
+	| ("Coq"::_::l) -> l
+	| l             -> l
+    in  List.iter (fun x -> print_string x; print_string ".") ls;*)
+      print_string (debug_string_of_mind sp)
+  and sp_con_display sp =
+(*    let dir,l = decode_kn sp in
+    let ls =
+      match List.rev_map Id.to_string (DirPath.repr dir) with
+          ("Top"::l)-> l
+	| ("Coq"::_::l) -> l
+	| l             -> l
+    in  List.iter (fun x -> print_string x; print_string ".") ls;*)
+      print_string (debug_string_of_con sp)
+
+  in
+    try
+     box_display csr; print_flush()
+    with e ->
+	print_string (Printexc.to_string e);print_flush ();
+	raise e
+
+
+
diff --git a/checker/reduction.ml b/checker/reduction.ml
index 91b59a08..185c6edf 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -1,15 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
-open Names
+open Cic
 open Term
-open Univ
 open Closure
 open Esubst
 open Environ
@@ -40,7 +40,10 @@ let compare_stack_shape stk1 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) ->
+    | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) ->
+        Int.equal bal 0 && compare_rec 0 s1 s2
+    | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1,
+       (Zcase(c2,_,_)|ZcaseT(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
@@ -49,6 +52,7 @@ let compare_stack_shape stk1 stk2 =
 
 type lft_constr_stack_elt =
     Zlapp of (lift * fconstr) array
+  | Zlproj of Names.constant * lift
   | Zlfix of (lift * fconstr) * lft_constr_stack
   | Zlcase of case_info * lift * fconstr * fconstr array
 and lft_constr_stack = lft_constr_stack_elt list
@@ -67,9 +71,13 @@ let pure_stack lfts stk =
             | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
             | (Zapp a, (l,pstk)) ->
                 (l,zlapp (Array.map (fun t -> (l,t)) a) pstk)
+	    | (Zproj (n,m,c), (l,pstk)) ->
+		(l, Zlproj (c,l)::pstk)
             | (Zfix(fx,a),(l,pstk)) ->
                 let (lfx,pa) = pure_rec l a in
                 (l, Zlfix((lfx,fx),pa)::pstk)
+            | (ZcaseT(ci,p,br,env),(l,pstk)) ->
+                (l,Zlcase(ci,l,mk_clos env p,mk_clos_vect env br)::pstk)
             | (Zcase(ci,p,br),(l,pstk)) ->
                 (l,Zlcase(ci,l,p,br)::pstk)) in
   snd (pure_rec lfts stk)
@@ -115,20 +123,27 @@ type 'a conversion_function = env -> 'a -> 'a -> unit
 exception NotConvertible
 exception NotConvertibleVect of int
 
+let convert_universes univ u u' =
+  if Univ.Instance.check_eq univ u u' then ()
+  else raise NotConvertible
+
 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
+            | (Zlapp a1,Zlapp a2) -> Array.iter2 f a1 a2
             | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
                 f fx1 fx2; cmp_rec a1 a2
+	    | (Zlproj (c1,l1),Zlproj (c2,l2)) -> 
+	      if not (Names.eq_con_chk c1 c2) then 
+		raise NotConvertible
             | (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
+                Array.iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2
             | _ -> assert false)
       | _ -> () in
   if compare_stack_shape stk1 stk2 then
@@ -143,7 +158,7 @@ type conv_pb =
 
 let sort_cmp univ pb s0 s1 =
   match (s0,s1) with
-    | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos & c2 = Null then raise NotConvertible
+    | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos && c2 = Null then raise NotConvertible
     | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible
     | (Prop c1, Type u)  ->
         (match pb with
@@ -152,8 +167,8 @@ let sort_cmp univ pb s0 s1 =
     | (Type u1, Type u2) ->
         if not
 	  (match pb with
-            | CONV -> check_eq univ u1 u2
-	    | CUMUL -> check_geq univ u2 u1)
+            | CONV -> Univ.check_eq univ u1 u2
+	    | CUMUL -> Univ.check_leq univ u1 u2)
         then raise NotConvertible
     | (_, _) -> raise NotConvertible
 
@@ -162,7 +177,9 @@ let rec no_arg_available = function
   | Zupdate _ :: stk -> no_arg_available stk
   | Zshift _ :: stk -> no_arg_available stk
   | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk
+  | Zproj _ :: _ -> true
   | Zcase _ :: _ -> true
+  | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
 let rec no_nth_arg_available n = function
@@ -173,7 +190,9 @@ let rec no_nth_arg_available n = function
       let k = Array.length v in
       if n >= k then no_nth_arg_available (n-k) stk
       else false
+  | Zproj _ :: _ -> true
   | Zcase _ :: _ -> true
+  | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
 let rec no_case_available = function
@@ -181,17 +200,19 @@ let rec no_case_available = function
   | Zupdate _ :: stk -> no_case_available stk
   | Zshift _ :: stk -> no_case_available stk
   | Zapp _ :: stk -> no_case_available stk
+  | Zproj (_,_,_) :: _ -> false
   | Zcase _ :: _ -> false
+  | ZcaseT _ :: _ -> false
   | Zfix _ :: _ -> true
 
 let in_whnf (t,stk) =
   match fterm_of t with
-    | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false
+    | (FLetIn _ | FCase _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false
     | FLambda _ -> no_arg_available stk
     | FConstruct _ -> no_case_available stk
     | FCoFix _ -> no_case_available stk
     | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk
-    | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true
+    | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true
     | FLOCKED -> assert false
 
 let oracle_order fl1 fl2 =
@@ -200,13 +221,18 @@ let oracle_order fl1 fl2 =
     | _, ConstKey _ -> true
     | _ -> false
 
+let unfold_projection infos p c =
+  let pb = lookup_projection p (infos_env infos) in
+  let s = Zproj (pb.proj_npars, pb.proj_arg, p) in
+    (c, s)
+
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
 let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 =
   eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[]))
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
 and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
-  Util.check_for_interrupt ();
+  Control.check_for_interrupt ();
   (* First head reduce both terms *)
   let rec whd_both (t1,stk1) (t2,stk2) =
     let st1' = whd_stack infos t1 stk1 in
@@ -246,7 +272,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
 	(try (* try first intensional equality *)
-	  if  eq_table_key fl1 fl2
+	  if eq_table_key fl1 fl2
           then convert_stacks univ infos lft1 lft2 v1 v2
           else raise NotConvertible
         with NotConvertible ->
@@ -254,19 +280,27 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
           let (app1,app2) =
             if oracle_order fl1 fl2 then
               match unfold_reference infos fl1 with
-                | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
-                | None ->
-                    (match unfold_reference infos fl2 with
-                      | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
-                     | None -> raise NotConvertible)
+              | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+              | None ->
+                (match unfold_reference infos fl2 with
+                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                | None -> raise NotConvertible)
             else
 	      match unfold_reference infos fl2 with
-                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
-                | None ->
-                    (match unfold_reference infos fl1 with
-                    | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
-		    | None -> raise NotConvertible) in
-          eqappr univ cv_pb infos app1 app2)
+              | 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)
+	  
+    | (FProj (p1,c1), _) ->
+      let (def1, s1) = unfold_projection infos p1 c1 in
+        eqappr univ cv_pb infos (lft1, whd_stack infos def1 (s1 :: v1)) appr2
+	  
+    | (_, FProj (p2,c2)) ->
+      let (def2, s2) = unfold_projection infos p2 c2 in
+        eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 (s2 :: v2))
 
     (* other constructors *)
     | (FLambda _, FLambda _) ->
@@ -287,43 +321,76 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
     (* Eta-expansion on the fly *)
     | (FLambda _, _) ->
         if v1 <> [] then
-          anomaly "conversion was given unreduced term (FLambda)";
+          anomaly (Pp.str "conversion was given unreduced term (FLambda)");
         let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
         eqappr univ CONV infos
           (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2))
     | (_, FLambda _) ->
         if v2 <> [] then
-          anomaly "conversion was given unreduced term (FLambda)";
+          anomaly (Pp.str "conversion was given unreduced term (FLambda)");
         let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
         eqappr univ CONV infos
           (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[]))
 
     (* only one constant, defined var or defined rel *)
-    | (FFlex fl1, _)      ->
+    | (FFlex fl1, c2)      ->
         (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)      ->
+           | None -> 
+	     match c2 with 
+	     | FConstruct ((ind2,j2),u2) ->
+	       (try
+ 	     	  let v2, v1 = 
+ 		    eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1)
+ 		  in convert_stacks univ infos lft1 lft2 v1 v2
+ 	     	with Not_found -> raise NotConvertible)
+	     | _ -> raise NotConvertible)
+
+    | (c1, 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)
+           | None -> 
+	     match c1 with 
+	     | FConstruct ((ind1,j1),u1) ->
+ 	       (try let v1, v2 = 
+		      eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2)
+		    in convert_stacks univ infos lft1 lft2 v1 v2
+		with Not_found -> raise NotConvertible)
+	     | _ -> raise NotConvertible)
 
     (* 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
+    | (FInd (ind1,u1), FInd (ind2,u2)) ->
+        if mind_equiv_infos infos ind1 ind2
+	then
+	  (let () = convert_universes univ u1 u2 in
+           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
+     | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) ->
+	 if Int.equal j1 j2 && mind_equiv_infos infos ind1 ind2
 	 then
-           convert_stacks univ infos lft1 lft2 v1 v2
+	  (let () = convert_universes univ u1 u2 in
+           convert_stacks univ infos lft1 lft2 v1 v2)
          else raise NotConvertible
 
+     (* Eta expansion of records *)
+     | (FConstruct ((ind1,j1),u1), _) ->
+       (try
+    	  let v1, v2 =
+    	    eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2)
+    	  in convert_stacks univ infos lft1 lft2 v1 v2
+	with Not_found -> raise NotConvertible)
+	 
+     | (_, FConstruct ((ind2,j2),u2)) ->
+       (try
+    	  let v2, v1 =
+    	    eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1)
+    	  in convert_stacks univ infos lft1 lft2 v1 v2
+	with Not_found -> raise NotConvertible)
+
      | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
 	 if op1 = op2
 	 then
@@ -353,8 +420,8 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
          else raise NotConvertible
 
      (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
-     | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
-       | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
+     | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
+       | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
        | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
 
      (* In all other cases, terms are not convertible *)
@@ -367,23 +434,25 @@ and convert_stacks univ infos lft1 lft2 stk1 stk2 =
     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
+  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 clos_fconv cv_pb eager_delta env t1 t2 =
+  let infos =
+    create_clos_infos
+      (if eager_delta then betadeltaiota else betaiotazeta) env in
   let univ = universes env in
   ccnv univ cv_pb infos el_id el_id (inject t1) (inject t2)
 
-let fconv cv_pb env t1 t2 =
+let fconv cv_pb eager_delta env t1 t2 =
   if eq_constr t1 t2 then ()
-  else clos_fconv cv_pb env t1 t2
+  else clos_fconv cv_pb eager_delta env t1 t2
 
-let conv = fconv CONV
-let conv_leq = fconv CUMUL
+let conv = fconv CONV false
+let conv_leq = fconv CUMUL false
 
 (* option for conversion : no compilation for the checker *)
 
-let vm_conv = fconv
+let vm_conv cv_pb = fconv cv_pb true
 
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
@@ -398,7 +467,7 @@ let vm_conv = fconv
 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"
+    | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
 
 let hnf_prod_applist env t nl =
   List.fold_left (hnf_prod_app env) t nl
@@ -416,7 +485,7 @@ let dest_prod env =
   in
   decrec env empty_rel_context
 
-(* The same but preserving lets *)
+(* The same but preserving lets in the context, not internal ones. *)
 let dest_prod_assum env =
   let rec prodec_rec env l ty =
     let rty = whd_betadeltaiota_nolet env ty in
@@ -428,10 +497,29 @@ let dest_prod_assum env =
         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
+    | _               ->
+      let rty' = whd_betadeltaiota env rty in
+	if Term.eq_constr rty' rty then l, rty
+	else prodec_rec env l rty'
   in
   prodec_rec env empty_rel_context
 
+let dest_lam_assum env =
+  let rec lamec_rec env l ty =
+    let rty = whd_betadeltaiota_nolet env ty in
+    match rty with
+    | Lambda (x,t,c)  ->
+        let d = (x,None,t) in
+	lamec_rec (push_rel d env) (d::l) c
+    | LetIn (x,b,t,c) ->
+        let d = (x,Some b,t) in
+	lamec_rec (push_rel d env) (d::l) c
+    | Cast (c,_,_)    -> lamec_rec env l c
+    | _               -> l,rty
+  in
+  lamec_rec env empty_rel_context
+
+
 let dest_arity env c =
   let l, c = dest_prod_assum env c in
   match c with
diff --git a/checker/reduction.mli b/checker/reduction.mli
index 67cd599c..2e873469 100644
--- a/checker/reduction.mli
+++ b/checker/reduction.mli
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
+open Cic
 open Term
 open Environ
 (*i*)
@@ -46,5 +47,7 @@ val hnf_prod_applist : env -> constr -> constr list -> constr
 
 val dest_prod       : env -> constr -> rel_context * constr
 val dest_prod_assum : env -> constr -> rel_context * constr
+val dest_lam_assum  : env -> constr -> rel_context * constr
+
 
 val dest_arity : env -> constr -> arity
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
index f7abd4dc..35f7f14b 100644
--- a/checker/safe_typing.ml
+++ b/checker/safe_typing.ml
@@ -1,15 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
+open Cic
 open Names
-open Declarations
 open Environ
 
 (************************************************************************)
@@ -24,9 +25,10 @@ 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 full_add_module dp mb univs digest =
   let env = !genv in
   let env = add_constraints mb.mod_constraints env in
+  let env = add_constraints univs env in
   let env = Modops.add_module mb env in
   genv := add_digest env dp digest
 
@@ -42,9 +44,9 @@ let check_engagement env c =
 
 let report_clash f caller dir =
   let msg =
-    str "compiled library " ++ str(string_of_dirpath caller) ++
+    str "compiled library " ++ str(DirPath.to_string caller) ++
     spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++
-    str(string_of_dirpath dir) ++ fnl() in
+    str(DirPath.to_string dir) ++ fnl() in
   f msg
 
 
@@ -54,121 +56,9 @@ let check_imports f caller env needed =
       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))
+      error ("Reference to unknown module " ^ (DirPath.to_string dp))
   in
-  List.iter check needed
-
-
-type compiled_library =
-    dir_path *
-    module_body *
-    (dir_path * Digest.t) list *
-    engagement option
-
- (* Store the body of modules' opaque constants inside a table.  
-
-    This module is used during the serialization and deserialization
-    of vo files. 
-
-    By adding an indirection to the opaque constant definitions, we
-    gain the ability not to load them. As these constant definitions
-    are usually big terms, we save a deserialization time as well as
-    some memory space. *)
-module LightenLibrary : sig
-  type table 
-  type lightened_compiled_library 
-  val load : table -> lightened_compiled_library -> compiled_library
-end = struct
-
-  (* The table is implemented as an array of [constr_substituted].
-     Keys are hence integers. To avoid changing the [compiled_library]
-     type, we brutally encode integers into [lazy_constr]. This isn't
-     pretty, but shouldn't be dangerous since the produced structure
-     [lightened_compiled_library] is abstract and only meant for writing
-     to .vo via Marshal (which doesn't care about types).
-  *)
-  type table = constr_substituted array
-  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
-
-  (* To avoid any future misuse of the lightened library that could 
-     interpret encoded keys as real [constr_substituted], we hide 
-     these kind of values behind an abstract datatype. *)
-  type lightened_compiled_library = compiled_library
-
-  (* Map a [compiled_library] to another one by just updating 
-     the opaque term [t] to [on_opaque_const_body t]. *)
-  let traverse_library on_opaque_const_body =
-    let rec traverse_module mb =
-      match mb.mod_expr with 
-	  None -> 
-	    { mb with
-		mod_expr = None;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }
-	| Some impl when impl == mb.mod_type-> 
-	    let mtb =  traverse_modexpr mb.mod_type in 
-	      { mb with
-		  mod_expr = Some mtb;
-		  mod_type = mtb;
-	      }    
-	| Some impl -> 
-	    { mb with
-		mod_expr = Option.map traverse_modexpr mb.mod_expr;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }    
-    and traverse_struct struc =
-      let traverse_body (l,body) = (l,match body with
-	| (SFBconst cb) when is_opaque cb ->
-	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
-	| (SFBconst _ | SFBmind _ ) as x -> 
-	  x
-	| SFBmodule m -> 
-	  SFBmodule (traverse_module m)
-	| SFBmodtype m -> 
-	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
-      in
-      List.map traverse_body struc
-	
-    and traverse_modexpr = function
-      | SEBfunctor (mbid,mty,mexpr) ->
-	SEBfunctor (mbid,
-		    ({mty with
-		      typ_expr = traverse_modexpr mty.typ_expr}),
-		    traverse_modexpr mexpr)
-      | SEBident mp as x -> x
-      | SEBstruct (struc) ->
-	SEBstruct  (traverse_struct struc)
-      | SEBapply (mexpr,marg,u) ->
-	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
-      | SEBwith (seb,wdcl) ->
-	SEBwith (traverse_modexpr seb,wdcl)
-    in
-    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
-
-  (* Loading is also a traversing that decodes the embedded keys that
-     are inside the [lightened_library]. If the [load_proof] flag is
-     set, we lookup inside the table to graft the
-     [constr_substituted]. Otherwise, we set the [const_body] field
-     to [None]. 
-  *)
-  let load table lightened_library =
-    let decode_key = function
-      | Undef _ | Def _ -> assert false
-      | OpaqueDef k ->
-          let k = key_of_lazy_constr k in
-	  let body =
-	    try table.(k)
-	    with _ -> error "Error while retrieving an opaque body"
-	  in
-	  OpaqueDef (lazy_constr_from_val body)
-    in
-    traverse_library decode_key lightened_library
-
-end
-
-open Validate
-let val_deps = val_list (val_tuple ~name:"dep"[|val_dp;no_val|])
-let val_vo = val_tuple ~name:"vo" [|val_dp;val_module;val_deps;val_opt val_eng|]
+  Array.iter check needed
 
 (* This function should append a certificate to the .vo file.
    The digest must be part of the certicate to rule out attackers
@@ -179,24 +69,20 @@ let stamp_library file digest = ()
 
 (* When the module is checked, digests do not need to match, but a
    warning is issued in case of mismatch *)
-let import file (dp,mb,depends,engmt as vo) digest =
-  Validate.apply !Flags.debug val_vo vo;
-  Flags.if_verbose msgnl (str "*** vo structure validated ***");
+let import file clib univs digest =
   let env = !genv in
-  check_imports msg_warning dp env depends;
-  check_engagement env engmt;
-  Mod_checking.check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb;
+  check_imports msg_warning clib.comp_name env clib.comp_deps;
+  check_engagement env clib.comp_enga;
+  let mb = clib.comp_mod in
+  Mod_checking.check_module
+    (add_constraints univs
+      (add_constraints mb.mod_constraints env)) mb.mod_mp mb;
   stamp_library file digest;
-  (* We drop proofs once checked *)
-(*  let mb = lighten_module mb in*)
-  full_add_module dp mb digest
+  full_add_module clib.comp_name mb univs digest
 
 (* When the module is admitted, digests *must* match *)
-let unsafe_import file (dp,mb,depends,engmt as vo) digest =
-  if !Flags.debug then ignore vo; (*Validate.apply !Flags.debug val_vo vo;*)
+let unsafe_import file clib univs 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
+  check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps;
+  check_engagement env clib.comp_enga;
+  full_add_module clib.comp_name clib.comp_mod univs digest
diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli
index c34d3508..e16e64e6 100644
--- a/checker/safe_typing.mli
+++ b/checker/safe_typing.mli
@@ -1,40 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Names
-open Term
+open Cic
 open Environ
 (*i*)
 
 val get_env : unit -> env
 
-(* exporting and importing modules *)
-type compiled_library
-
-val set_engagement : Declarations.engagement -> unit
+val set_engagement : engagement -> unit
 val import         :
-  System.physical_path -> compiled_library -> Digest.t -> unit
+  CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit
 val unsafe_import  :
-  System.physical_path -> compiled_library -> Digest.t -> unit
-
-(** Store the body of modules' opaque constants inside a table. 
-
-    This module is used during the serialization and deserialization
-    of vo files. 
-*)
-module LightenLibrary :
-sig
-  type table 
-  type lightened_compiled_library 
-
-  (** [load table lcl] builds a compiled library from a
-      lightened library [lcl] by remplacing every index by its related
-      opaque terms inside [table]. *)
-  val load : table -> lightened_compiled_library -> compiled_library
-end
+  CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
index 02821c29..372c3142 100644
--- a/checker/subtyping.ml
+++ b/checker/subtyping.ml
@@ -1,15 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
+open Errors
 open Util
 open Names
-open Univ
+open Cic
 open Term
 open Declarations
 open Environ
@@ -17,9 +18,6 @@ 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
@@ -37,42 +35,42 @@ type namedmodule =
    constructors *)
 
 let add_mib_nameobjects mp l mib map =
-  let ind = make_mind mp empty_dirpath l in
+  let ind = MutInd.make2 mp l in
   let add_mip_nameobjects j oib map =
     let ip = (ind,j) in
     let map =
-      array_fold_right_i
+      Array.fold_right_i
       (fun i id map ->
-        Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
+        Label.Map.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
+      Label.Map.add (Label.of_id oib.mind_typename) (IndType (ip, mib)) map
   in
-    array_fold_right_i add_mip_nameobjects mib.mind_packets map
+    Array.fold_right_i add_mip_nameobjects mib.mind_packets map
 
 
 (* creates (namedobject/namedmodule) map for the whole signature *)
 
-type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
+type labmap = { objs : namedobject Label.Map.t; mods : namedmodule Label.Map.t }
 
-let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
+let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty }
 
 let get_obj mp map l =
-  try Labmap.find l map.objs
+  try Label.Map.find l map.objs
   with Not_found -> error_no_such_label_sub l mp
 
 let get_mod mp map l =
-  try Labmap.find l map.mods
+  try Label.Map.find l map.mods
   with Not_found -> error_no_such_label_sub l mp
 
 let make_labmap mp list =
   let add_one (l,e) map =
    match e with
-    | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
+    | SFBconst cb -> { map with objs = Label.Map.add l (Constant cb) map.objs }
     | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
-    | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
-    | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
+    | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods }
+    | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods }
   in
   List.fold_right add_one list empty_labmap
 
@@ -85,7 +83,7 @@ let check_conv_error error f env a1 a2 =
 
 (* for now we do not allow reorderings *)
 let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2= 
-  let kn = make_mind  mp1 empty_dirpath l in
+  let kn = MutInd.make2 mp1 l in
   let error () = error_not_match l spec2 in
   let check_conv f = check_conv_error error f in
   let mib1 =
@@ -93,7 +91,26 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
       | IndType ((_,0), mib) -> mib
       | _ -> error ()
   in
-  let mib2 =  subst_mind subst2 mib2 in
+  let mib2 = subst_mind subst2 mib2 in
+  let check eq f = if not (eq (f mib1) (f mib2)) then error () in
+  let bool_equal (x : bool) (y : bool) = x = y in
+  let u = 
+    check bool_equal (fun x -> x.mind_polymorphic);
+    if mib1.mind_polymorphic then (
+      check Univ.Instance.equal (fun x -> Univ.UContext.instance x.mind_universes);
+      Univ.UContext.instance mib1.mind_universes)
+    else Univ.Instance.empty
+  in
+  let eq_projection_body p1 p2 =
+    let check eq f = if not (eq (f p1) (f p2)) then error () in
+    check eq_mind (fun x -> x.proj_ind);
+    check (==) (fun x -> x.proj_npars);
+    check (==) (fun x -> x.proj_arg);
+    check (eq_constr) (fun x -> x.proj_type);
+    check (eq_constr) (fun x -> fst x.proj_eta);
+    check (eq_constr) (fun x -> snd x.proj_eta);
+    check (eq_constr) (fun x -> x.proj_body); true
+  in
   let check_inductive_type env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
@@ -130,14 +147,16 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
   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);
+    let check eq f = if not (eq (f p1) (f p2)) then error () in
+    check
+      (fun a1 a2 -> Array.equal Id.equal a1 a2)
+      (fun p -> p.mind_consnames);
+      check Id.equal (fun p -> p.mind_typename);
       (* nf_lc later *)
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      check (fun p -> p.mind_nrealargs);
+      check Int.equal (fun p -> p.mind_nrealargs);
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
@@ -145,17 +164,15 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
       (* 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))
+        (type_of_inductive env ((mib1,p1),u)) (type_of_inductive env ((mib2,p2),u))
   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))
+    Array.iter2 (check_conv conv env)
+      (arities_of_specif (kn,u) (mib1,p1))
+      (arities_of_specif (kn,u) (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=[]);
+  check (==) (fun mib -> mib.mind_finite);
+  check Int.equal (fun mib -> mib.mind_ntypes);
   assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
 
@@ -164,7 +181,7 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
   (* at the time of checking the inductive arities in check_packet. *)
   (* Notice that we don't expect the local definitions to match: only *)
   (* the inductive types and constructors types have to be convertible *)
-  check (fun mib -> mib.mind_nparams);
+  check Int.equal (fun mib -> mib.mind_nparams);
 
   (*begin
     match mib2.mind_equiv with
@@ -178,8 +195,18 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
 	    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 record_equal x y =
+    match x, y with
+    | None, None -> true
+    | Some None, Some None -> true
+    | Some (Some (id1,p1,pb1)), Some (Some (id2,p2,pb2)) ->
+      Id.equal id1 id2 &&
+      Array.for_all2 eq_con_chk p1 p2 &&
+      Array.for_all2 eq_projection_body pb1 pb2
+    | _, _ -> false
+  in
+  check record_equal (fun mib -> mib.mind_record);
+  if mib1.mind_record != None 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)
@@ -190,12 +217,14 @@ let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2=
     assert (Array.length mib2.mind_packets = 1);
     assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
     assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
-    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
+    check
+      (fun l1 l2 -> List.equal Name.equal l1 l2)
+      (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;
+  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
+  let _ = Array.map2_i check_cons_types mib1.mind_packets mib2.mind_packets
   in ()
 
 let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
@@ -216,13 +245,13 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
       if isArity t2 then
         let (ctx2,s2) = destArity t2 in
         match s2 with
-        | Type v when not (is_univ_variable v) ->
+        | 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 (is_univ_variable u) ->
+            | 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)
@@ -249,7 +278,6 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
   in
     match info1 with
       | Constant cb1 ->
-	assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
 	let cb1 = subst_const_body subst1 cb1 in
 	let cb2 = subst_const_body subst2 cb2 in
 	(*Start by checking types*)
@@ -274,25 +302,25 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
 		let c2 = force_constr lc2 in
 		check_conv conv env c1 c2))
       | IndType ((kn,i),mind1) ->
-	  ignore (Util.error (
+	  ignore (Errors.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 constant_has_body cb2 then error () ;
-      let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
+      let u = inductive_instance mind1 in
+      let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) 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 (
+      ignore (Errors.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 constant_has_body cb2 then error () ;
-      let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
+      let u1 = inductive_instance mind1 in
+      let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
        check_conv conv env ty1 ty2
 
@@ -325,56 +353,53 @@ and check_signatures env mp1 sig1 sig2 subst1 subst2 =
 		| Modtype mtb -> mtb
 		| _ -> error_not_match l spec2
 	    in
-	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
-	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
-	      check_modtypes  env mtb1 mtb2 subst1 subst2 true
+	    let env =
+              add_module_type mtb2.mod_mp mtb2
+	        (add_module_type mtb1.mod_mp mtb1 env)
+            in
+	    check_modtypes env mtb1 mtb2 subst1 subst2 true
   in
-    List.iter check_one_body sig2
-
-and check_modtypes  env mtb1 mtb2 subst1 subst2 equiv = 
-  if mtb1==mtb2 then () else 
-  let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in
-  let rec check_structure  env str1 str2 equiv subst1 subst2 = 
-	match str1,str2 with
-	  | SEBstruct (list1), 
-	    SEBstruct (list2) -> 
-	       check_signatures env
-		mtb1.typ_mp list1 list2 subst1 subst2;
-		if equiv then
-		  check_signatures  env 
-		     mtb2.typ_mp list2 list1 subst1 subst2
-		else
-		  ()
-	  | SEBfunctor (arg_id1,arg_t1,body_t1),
-	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
-	       check_modtypes env 
-		arg_t2 arg_t1
-		(map_mp arg_t1.typ_mp arg_t2.typ_mp) subst2
-		equiv ;
-		(* contravariant *)
-	      let env = add_module 
-		(module_body_of_type (MPbound arg_id2) arg_t2) env 
-	      in
-	      let env = match body_t1 with
-		  SEBstruct str ->
-		    let env = shallow_remove_module mtb1.typ_mp env in
-		    add_module {mod_mp = mtb1.typ_mp;
-				mod_expr = None;
-				mod_type = body_t1;
-				mod_type_alg= None;
-				mod_constraints=mtb1.typ_constraints;
-				mod_retroknowledge = [];
-				mod_delta = mtb1.typ_delta} env
-		| _ -> env
-	      in
-		check_structure env body_t1 body_t2 equiv 
-		  (join (map_mbid arg_id1 (MPbound arg_id2)) subst1)
-		  subst2
-	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
-      in
-     if mtb1'== mtb2' then ()
-     else check_structure  env mtb1' mtb2' equiv subst1 subst2
+  List.iter check_one_body sig2
+
+and check_modtypes env mtb1 mtb2 subst1 subst2 equiv =
+  if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then ()
+  else
+    let rec check_structure  env str1 str2 equiv subst1 subst2 =
+      match str1,str2 with
+      | NoFunctor (list1),
+        NoFunctor (list2) ->
+	  check_signatures env mtb1.mod_mp list1 list2 subst1 subst2;
+	  if equiv then
+	    check_signatures env mtb2.mod_mp list2 list1 subst1 subst2
+	  else
+	    ()
+      | MoreFunctor (arg_id1,arg_t1,body_t1),
+	MoreFunctor (arg_id2,arg_t2,body_t2) ->
+	  check_modtypes env
+	    arg_t2 arg_t1
+	    (map_mp arg_t1.mod_mp arg_t2.mod_mp) subst2
+	    equiv;
+	  (* contravariant *)
+	  let env = add_module_type (MPbound arg_id2) arg_t2 env in
+	  let env =
+            if is_functor body_t1 then env
+            else
+	      let env = shallow_remove_module mtb1.mod_mp env in
+	      add_module {mod_mp = mtb1.mod_mp;
+			  mod_expr = Abstract;
+			  mod_type = body_t1;
+			  mod_type_alg = None;
+			  mod_constraints = mtb1.mod_constraints;
+			  mod_retroknowledge = [];
+			  mod_delta = mtb1.mod_delta} env
+	  in
+	  check_structure env body_t1 body_t2 equiv
+	    (join (map_mbid arg_id1 (MPbound arg_id2)) subst1)
+	    subst2
+      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+    in
+    check_structure env mtb1.mod_type mtb2.mod_type equiv subst1 subst2
 
 let check_subtypes env sup super =
-  check_modtypes env (strengthen sup sup.typ_mp) super empty_subst
-      (map_mp super.typ_mp sup.typ_mp) false
+  check_modtypes env (strengthen sup sup.mod_mp) super empty_subst
+      (map_mp super.mod_mp sup.mod_mp) false
diff --git a/checker/subtyping.mli b/checker/subtyping.mli
index bef5a6b1..03242cbc 100644
--- a/checker/subtyping.mli
+++ b/checker/subtyping.mli
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Univ
-open Term
-open Declarations
+open Cic
 open Environ
 (*i*)
 
diff --git a/checker/term.ml b/checker/term.ml
index d0d7805d..93540276 100644
--- a/checker/term.ml
+++ b/checker/term.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,132 +8,36 @@
 
 (* This module instantiates the structure of generic deBruijn terms to Coq *)
 
+open Errors
 open Util
-open Pp
 open Names
-open Univ
 open Esubst
-open Validate
-
-(* 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 | LetPatternStyle | MatchStyle |
-  RegularStyle
-type case_printing =
-  { ind_nargs : int; (* length of the arity of the inductive type *)
-    style     : case_style }
-type case_info =
-  { ci_ind         : inductive;
-    ci_npar        : int;
-    ci_cstr_ndecls : int array; (* number of pattern var of each constructor *)
-    ci_pp_info     : case_printing (* not interpreted by the kernel *)
-  }
-let val_ci =
-  let val_cstyle = val_enum "case_style" 5 in
-  let val_cprint = val_tuple ~name:"case_printing" [|val_int;val_cstyle|] in
-  val_tuple ~name:"case_info" [|val_ind;val_int;val_array val_int;val_cprint|]
 
-(* Sorts. *)
-
-type contents = Pos | Null
-
-type sorts =
-  | Prop of contents                      (* proposition types *)
-  | Type of universe
+open Cic
 
-type sorts_family = InProp | InSet | InType
+(* Sorts. *)
 
 let family_of_sort = function
   | Prop Null -> InProp
   | Prop Pos -> InSet
   | Type _ -> InType
 
-let val_sort = val_sum "sort" 0 [|[|val_enum "cnt" 2|];[|val_univ|]|]
-let val_sortfam = val_enum "sorts_family" 3
+let family_equal = (==)
+
+let sort_of_univ u =
+  if Univ.is_type0m_univ u then Prop Null
+  else if Univ.is_type0_univ u then Prop Pos
+  else Type u
 
 (********************************************************************)
 (*       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
-
-let val_evar f = val_tuple ~name:"pexistential" [|val_int;val_array f|]
-let val_prec f =
-  val_tuple ~name:"prec_declaration"
-    [|val_array val_name; val_array f; val_array f|]
-let val_fix f =
-  val_tuple ~name:"pfixpoint"
-    [|val_tuple~name:"fix2"[|val_array val_int;val_int|];val_prec f|]
-let val_cofix f = val_tuple ~name:"pcofixpoint"[|val_int;val_prec f|]
-
-type cast_kind = VMcast | DEFAULTcast
-let val_cast = val_enum "cast_kind" 2
-
-(*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
-
-let val_constr = val_rec_sum "constr" 0 (fun val_constr -> [|
-  [|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_con|]; (* 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 *)
-|])
-
-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
+let collapse_appl c = match c with
   | App (f,cl) ->
       let rec collapse_rec f cl2 =
         match (strip_outer_cast f) with
@@ -176,6 +80,7 @@ let iter_constr_with_binders g f n c = match c with
   | CoFix (_,(_,tl,bl)) ->
       Array.iter (f n) tl;
       Array.iter (f (iterate g (Array.length tl) n)) bl
+  | Proj (p, c) -> f n c
 
 exception LocalOccur
 
@@ -197,7 +102,7 @@ let closed0 = closedn 0
 
 let noccurn n term =
   let rec occur_rec n c = match c with
-    | Rel m -> if m = n then raise LocalOccur
+    | Rel m -> if Int.equal m n then raise LocalOccur
     | _ -> iter_constr_with_binders succ occur_rec n c
   in
   try occur_rec n term; true with LocalOccur -> false
@@ -221,7 +126,7 @@ let noccur_between n m term =
 
 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
+    | Rel p -> if n<=p && p<n+m then raise LocalOccur
     | App(f,cl) ->
 	(match f with
            | (Cast (Meta _,_,_)| Meta _) -> ()
@@ -252,6 +157,7 @@ let map_constr_with_binders g f l c = match c with
   | 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))
+  | Proj (p, c) -> Proj (p, f l c)
 
 (* The generic lifting function *)
 let rec exliftn el c = match c with
@@ -291,7 +197,7 @@ 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
+  if Int.equal lv 0 then c
   else
     let rec substrec depth c = match c with
       | Rel k     ->
@@ -311,23 +217,6 @@ let subst1 lam = substl [lam]
 (*     Type of assumptions and contexts                                    *)
 (***************************************************************************)
 
-let val_ndecl =
-  val_tuple ~name:"named_declaration"[|val_id;val_opt val_constr;val_constr|]
-let val_rdecl =
-  val_tuple ~name:"rel_declaration"[|val_name;val_opt val_constr;val_constr|]
-let val_nctxt = val_list val_ndecl
-let val_rctxt = val_list val_rdecl
-
-type named_declaration = identifier * constr option * constr
-type rel_declaration = name * constr option * constr
-
-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 =
@@ -338,16 +227,14 @@ let rel_context_nhyps hyps =
   nhyps 0 hyps
 let fold_rel_context f l ~init = List.fold_right f l init
 
-let map_context f l =
+let map_rel_context f l =
   let map_decl (n, body_o, typ as decl) =
     let body_o' = Option.smartmap f body_o in
     let typ' = f typ in
       if body_o' == body_o && typ' == typ then decl else
 	(n, body_o', typ')
   in
-    list_smartmap map_decl l
-
-let map_rel_context = map_context
+    List.smartmap map_decl l
 
 let extended_rel_list n hyps =
   let rec reln l p = function
@@ -383,7 +270,7 @@ 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
+    if Int.equal 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
@@ -416,7 +303,7 @@ 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
+    if Int.equal 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
@@ -441,7 +328,7 @@ let destArity =
     | 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"
+    | _               -> anomaly ~label:"destArity" (Pp.str "not an arity")
   in
   prodec_rec []
 
@@ -459,40 +346,99 @@ let rec isArity c =
 
 (* alpha conversion : ignore print names and casts *)
 
+let compare_sorts s1 s2 = match s1, s2 with
+| Prop c1, Prop c2 ->
+  begin match c1, c2 with
+  | Pos, Pos | Null, Null -> true
+  | Pos, Null -> false
+  | Null, Pos -> false
+  end
+| Type u1, Type u2 -> Univ.Universe.equal u1 u2
+| Prop _, Type _ -> false
+| Type _, Prop _ -> false
+
+let eq_puniverses f (c1,u1) (c2,u2) =
+  Univ.Instance.equal u1 u2 && f c1 c2
+
 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
+  | Rel n1, Rel n2 -> Int.equal n1 n2
+  | Meta m1, Meta m2 -> Int.equal m1 m2
+  | Var id1, Var id2 -> Id.equal id1 id2
+  | Sort s1, Sort s2 -> compare_sorts 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
+  | 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
+      if Int.equal (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
+        if Int.equal (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 -> eq_con_chk c1 c2
-  | Ind c1, Ind c2 -> eq_ind_chk c1 c2
-  | Construct (c1,i1), Construct (c2,i2) -> i1=i2 && eq_ind_chk c1 c2
+  | Evar (e1,l1), Evar (e2,l2) -> Int.equal e1 e2 && Array.equal f l1 l2
+  | Const c1, Const c2 -> eq_puniverses eq_con_chk c1 c2
+  | Ind c1, Ind c2 -> eq_puniverses eq_ind_chk c1 c2
+  | Construct ((c1,i1),u1), Construct ((c2,i2),u2) -> Int.equal i1 i2 && eq_ind_chk c1 c2
+    && Univ.Instance.equal u1 u2
   | 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
+      f p1 p2 && f c1 c2 && Array.equal f bl1 bl2
+  | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+      Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 &&
+      Array.equal f tl1 tl2 && Array.equal 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
+      Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2
+  | Proj (p1,c1), Proj(p2,c2) -> eq_con_chk p1 p2 && f c1 c2
   | _ -> false
 
 let rec eq_constr m n =
-  (m==n) or
+  (m == n) ||
   compare_constr eq_constr m n
 
 let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+(* Universe substitutions *)
+
+let map_constr f c = map_constr_with_binders (fun x -> x) (fun _ c -> f c) 0 c
+
+let subst_instance_constr subst c =
+  if Univ.Instance.is_empty subst then c
+  else
+    let f u = Univ.subst_instance_instance subst u in
+    let changed = ref false in
+    let rec aux t = 
+      match t with
+      | Const (c, u) -> 
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; Const (c, u'))
+      | Ind (i, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+	  let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; Ind (i, u'))
+      | Construct (c, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; Construct (c, u'))
+      | Sort (Type u) -> 
+         let u' = Univ.subst_instance_universe subst u in
+	   if u' == u then t else 
+	     (changed := true; Sort (sort_of_univ u'))
+      | _ -> map_constr aux t
+    in
+    let c' = aux c in
+      if !changed then c' else c
+
+let subst_instance_context s ctx = 
+  if Univ.Instance.is_empty s then ctx
+  else map_rel_context (fun x -> subst_instance_constr s x) ctx
diff --git a/checker/term.mli b/checker/term.mli
index 0340c79b..ab488b2b 100644
--- a/checker/term.mli
+++ b/checker/term.mli
@@ -1,50 +1,9 @@
 open Names
+open Cic
 
-type existential_key = int
-type metavariable = int
-type case_style =
-    LetStyle
-  | IfStyle
-  | LetPatternStyle
-  | MatchStyle
-  | RegularStyle
-type case_printing = { ind_nargs : int; style : case_style; }
-type case_info = {
-  ci_ind : inductive;
-  ci_npar : int;
-  ci_cstr_ndecls : int array;
-  ci_pp_info : case_printing;
-}
-type contents = Pos | Null
-type sorts = Prop of contents | Type of Univ.universe
-type sorts_family = InProp | InSet | InType
 val family_of_sort : sorts -> sorts_family
-type 'a pexistential = existential_key * 'a array
-type 'a prec_declaration = name array * 'a array * 'a array
-type 'a pfixpoint = (int array * int) * 'a prec_declaration
-type 'a pcofixpoint = int * 'a prec_declaration
-type cast_kind = VMcast | DEFAULTcast
-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
+val family_equal : sorts_family -> sorts_family -> bool
+
 val strip_outer_cast : constr -> constr
 val collapse_appl : constr -> constr
 val decompose_app : constr -> constr * constr list
@@ -71,20 +30,11 @@ val substnl : constr list -> int -> constr -> constr
 val substl : constr list -> constr -> constr
 val subst1 : constr -> constr -> constr
 
-type named_declaration = identifier * constr option * constr
-type rel_declaration = name * constr option * constr
-type named_context = named_declaration list
-val empty_named_context : named_context
-val fold_named_context :
-  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-type section_context = named_context
-type rel_context = rel_declaration list
 val empty_rel_context : rel_context
 val rel_context_length : rel_context -> int
 val rel_context_nhyps : rel_context -> int
 val fold_rel_context :
   (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-val map_context : (constr -> constr) -> named_context -> named_context
 val map_rel_context : (constr -> constr) -> rel_context -> rel_context
 val extended_rel_list : int -> rel_context -> constr list
 val compose_lam : (name * constr) list -> constr -> constr
@@ -96,15 +46,13 @@ val decompose_prod_assum : constr -> rel_context * constr
 val decompose_prod_n_assum : int -> constr -> rel_context * constr
 
 type arity = rel_context * sorts
+
 val mkArity : arity -> constr
 val destArity : constr -> arity
 val isArity : constr -> bool
 val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 val eq_constr : constr -> constr -> bool
 
-(* Validation *)
-val val_sortfam : Validate.func
-val val_sort : Validate.func
-val val_constr : Validate.func
-val val_rctxt : Validate.func
-val val_nctxt : Validate.func
+(** Instance substitution for polymorphism. *)
+val subst_instance_constr : Univ.universe_instance -> constr -> constr
+val subst_instance_context : Univ.universe_instance -> rel_context -> rel_context
diff --git a/checker/type_errors.ml b/checker/type_errors.ml
index e25f7d18..c4c65286 100644
--- a/checker/type_errors.ml
+++ b/checker/type_errors.ml
@@ -1,13 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Term
+open Cic
 open Environ
 
 type unsafe_judgment = constr * constr
@@ -33,6 +33,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -45,7 +46,7 @@ type type_error =
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
   | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
@@ -59,6 +60,7 @@ type type_error =
   | IllFormedRecBody of guard_error * name array * int
   | IllTypedRecBody of
       int * name array * unsafe_judgment array * constr array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
@@ -107,4 +109,5 @@ let error_ill_formed_rec_body env why lna i =
 let error_ill_typed_rec_body env i lna vdefj vargs =
   raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
 
-
+let error_unsatisfied_constraints env c =
+  raise (TypeError (env, UnsatisfiedConstraints c))
diff --git a/checker/type_errors.mli b/checker/type_errors.mli
index e40a05c9..036ff454 100644
--- a/checker/type_errors.mli
+++ b/checker/type_errors.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 
 (*i*)
 open Names
-open Term
+open Cic
 open Environ
 (*i*)
 
@@ -35,6 +35,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -47,7 +48,7 @@ type type_error =
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
   | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
@@ -61,6 +62,7 @@ type type_error =
   | IllFormedRecBody of guard_error * name array * int
   | IllTypedRecBody of
       int * name array * unsafe_judgment array * constr array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
@@ -75,7 +77,7 @@ 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 ->
+  env -> pinductive -> sorts_family list -> constr -> unsafe_judgment ->
       (sorts_family * sorts_family * arity_error) option -> 'a
 
 val error_case_not_inductive : env -> unsafe_judgment -> 'a
@@ -99,3 +101,4 @@ val error_ill_formed_rec_body :
 val error_ill_typed_rec_body  :
   env -> int -> name array -> unsafe_judgment array -> constr array -> 'a
 
+val error_unsatisfied_constraints : env -> Univ.constraints -> 'a
diff --git a/checker/typeops.ml b/checker/typeops.ml
index 6b0c6eaf..9bc4b269 100644
--- a/checker/typeops.ml
+++ b/checker/typeops.ml
@@ -1,25 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
-open Univ
+open Cic
 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
+  Array.fold_left2_i
     (fun i _ t1 t2 ->
       (try conv_leq env t1 t2
       with NotConvertible -> raise (NotConvertibleVect i)); ())
@@ -27,6 +27,10 @@ let conv_leq_vecti env v1 v2 =
     v1
     v2
 
+let check_constraints cst env = 
+  if Environ.check_constraints cst env then ()
+  else error_unsatisfied_constraints env cst
+
 (* 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
@@ -48,11 +52,11 @@ let assumption_of_judgment env j =
 
 (* Prop and Set *)
 
-let judge_of_prop = Sort (Type type1_univ)
+let judge_of_prop = Sort (Type Univ.type1_univ)
 
 (* Type of Type(i). *)
 
-let judge_of_type u = Sort (Type (super u))
+let judge_of_type u = Sort (Type (Univ.super u))
 
 (*s Type of a de Bruijn index. *)
 
@@ -63,53 +67,36 @@ let judge_of_relative env n =
   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
-
 (* Type of constants *)
 
-let type_of_constant_knowing_parameters env t paramtyps =
+
+let type_of_constant_type_knowing_parameters env t paramtyps =
   match t with
-  | NonPolymorphicType t -> t
-  | PolymorphicArity (sign,ar) ->
+  | RegularArity t -> t
+  | TemplateArity (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_knowing_parameters env cst paramtyps =
+  let ty, cu = constant_type env cst in
+    type_of_constant_type_knowing_parameters env ty paramtyps, cu
+
 let type_of_constant_type env t =
-  type_of_constant_knowing_parameters env t [||]
+  type_of_constant_type_knowing_parameters env t [||]
 
-let judge_of_constant_knowing_parameters env cst paramstyp =
-  let c = Const cst in
-  let cb =
-    try lookup_constant cst env
+let type_of_constant env cst =
+  type_of_constant_knowing_parameters env cst [||]
+
+let judge_of_constant_knowing_parameters env (kn,u as cst) paramstyp =
+  let _cb =
+    try lookup_constant kn env
     with Not_found ->
-      failwith ("Cannot find constant: "^string_of_con cst) in
-  let _ = check_args env c cb.const_hyps in
-  type_of_constant_knowing_parameters env cb.const_type paramstyp
+      failwith ("Cannot find constant: "^string_of_con kn)
+  in
+  let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in
+  let () = check_constraints cu env in
+    ty
 
 let judge_of_constant env cst =
   judge_of_constant_knowing_parameters env cst [||]
@@ -146,13 +133,13 @@ let sort_of_product env domsort rangsort =
           rangsort
         else
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          Type (sup u1 type0_univ)
+          Type (Univ.sup u1 Univ.type0_univ)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
+    | (Prop Pos,  Type u2)  -> Type (Univ.sup Univ.type0_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 u1, Type u2) -> Type (Univ.sup u1 u2)
 
 (* Type of a type cast *)
 
@@ -166,7 +153,7 @@ let sort_of_product env domsort rangsort =
 let judge_of_cast env (c,cj) k tj =
   let conversion =
     match k with
-    | VMcast -> vm_conv CUMUL
+    | VMcast | NATIVEcast -> vm_conv CUMUL
     | DEFAULTcast -> conv_leq in
   try
     conversion env cj tj
@@ -187,31 +174,27 @@ let judge_of_cast env (c,cj) k tj =
    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) =
+let judge_of_inductive_knowing_parameters env (ind,u) (paramstyp:constr array) =
+  let specif =
     try lookup_mind_specif env ind
     with Not_found ->
-      failwith ("Cannot find inductive: "^string_of_mind (fst ind)) in
-  check_args env c mib.mind_hyps;
-  type_of_inductive_knowing_parameters env mip paramstyp
+      failwith ("Cannot find inductive: "^string_of_mind (fst ind))
+  in
+  type_of_inductive_knowing_parameters env (specif,u) 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 =
-      try lookup_mind kn env
-      with Not_found ->
-        failwith ("Cannot find inductive: "^string_of_mind (fst (fst c))) 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
+let judge_of_constructor env (c,u) =
+  let ind = inductive_of_constructor c in
+  let specif =
+    try lookup_mind_specif env ind
+    with Not_found ->
+      failwith ("Cannot find inductive: "^string_of_mind (fst ind))
+  in
+  type_of_constructor (c,u) specif
 
 (* Case. *)
 
@@ -227,11 +210,23 @@ 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 _ = check_case_info env (fst (fst indspec)) ci in
   let (bty,rslty) = type_case_branches env indspec pj c in
   check_branch_types env (c,cj) (lfj,bty);
   rslty
 
+(* Projection. *)
+
+let judge_of_projection env p c ct =
+  let pb = lookup_projection p env in
+  let (ind,u), args =
+    try find_rectype env ct
+    with Not_found -> error_case_not_inductive env (c, ct)
+  in
+    assert(eq_mind pb.proj_ind (fst ind));
+    let ty = subst_instance_constr u pb.proj_type in
+      substl (c :: List.rev args) ty
+
 (* Fixpoints. *)
 
 (* Checks the type of a general (co)fixpoint, i.e. without checking *)
@@ -243,21 +238,21 @@ let type_fixpoint env lna lar lbody vdefj =
   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
+    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 empty_constraint) env in
-        env', mkArity (ctxt,Type u')
-    | _ -> env, ar
+(* 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_leq u u' empty_constraint) env in *)
+(*         env', mkArity (ctxt,Type u') *)
+(*     | _ -> env, ar *)
 
 
 (* The typing machine. *)
@@ -270,7 +265,7 @@ let rec execute env cstr =
 
     | Rel n -> judge_of_relative env n
 
-    | Var id -> judge_of_variable env id
+    | Var _ -> anomaly (Pp.str "Section variable in Coqchk !")
 
     | Const c -> judge_of_constant env c
 
@@ -292,9 +287,13 @@ let rec execute env cstr =
 		(* No sort-polymorphism *)
 		execute env f
 	in
-        let jl = array_map2 (fun c ty -> c,ty) args jl in
+        let jl = Array.map2 (fun c ty -> c,ty) args jl in
 	judge_of_apply env (f,j) jl
 
+    | Proj (p, c) ->
+        let ct = execute env c in
+          judge_of_projection env p c ct
+
     | Lambda (name,c1,c2) ->
         let _ = execute_type env c1 in
 	let env1 = push_rel (name,None,c1) env in
@@ -312,7 +311,7 @@ let rec execute env cstr =
         (* /!\ c2 can be an inferred type => refresh
            (but the pushed type is still c2) *)
         let _ =
-          let env',c2' = refresh_arity env c2 in
+          let env',c2' = (* refresh_arity env *) 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
@@ -350,10 +349,10 @@ let rec execute env cstr =
 
     (* Partial proofs: unsupported by the kernel *)
     | Meta _ ->
-	anomaly "the kernel does not support metavariables"
+	anomaly (Pp.str "the kernel does not support metavariables")
 
     | Evar _ ->
-	anomaly "the kernel does not support existential variables"
+	anomaly (Pp.str "the kernel does not support existential variables")
 
 and execute_type env constr =
   let j = execute env constr in
@@ -361,7 +360,7 @@ and execute_type env constr =
 
 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 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
@@ -389,32 +388,15 @@ let check_ctxt env rels =
           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
-
 (* Polymorphic arities utils *)
 
 let check_kind env ar u =
-  if snd (dest_prod env ar) = Sort(Type u) then ()
-  else failwith "not the correct sort"
+  match (snd (dest_prod env ar)) with
+  | Sort (Type u') when Univ.Universe.equal u' (Univ.Universe.make u) -> ()
+  | _ -> failwith "not the correct sort"
 
 let check_polymorphic_arity env params par =
-  let pl = par.poly_param_levels in
+  let pl = par.template_param_levels in
   let rec check_p env pl params =
     match pl, params with
         Some u::pl, (na,None,ty)::params ->
diff --git a/checker/typeops.mli b/checker/typeops.mli
index bd7249f1..39d66041 100644
--- a/checker/typeops.mli
+++ b/checker/typeops.mli
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Names
-open Term
-open Declarations
+open Cic
 open Environ
 (*i*)
 
@@ -18,9 +16,8 @@ open Environ
 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 check_polymorphic_arity :
-  env -> rel_context -> polymorphic_arity -> unit
+  env -> rel_context -> template_arity -> unit
 
 val type_of_constant_type : env -> constant_type -> constr
 
diff --git a/checker/univ.ml b/checker/univ.ml
new file mode 100644
index 00000000..5fed6dcd
--- /dev/null
+++ b/checker/univ.ml
@@ -0,0 +1,1253 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *)
+(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *)
+(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *)
+(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
+
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+
+open Pp
+open Errors
+open Util
+
+(* Universes are stratified by a partial ordering $\le$.
+   Let $\~{}$ be the associated equivalence. We also have a strict ordering
+   $<$ between equivalence classes, and we maintain that $<$ is acyclic,
+   and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$.
+
+   At every moment, we have a finite number of universes, and we
+   maintain the ordering in the presence of assertions $U<V$ and $U\le V$.
+
+   The equivalence $\~{}$ is represented by a tree structure, as in the
+   union-find algorithm. The assertions $<$ and $\le$ are represented by
+   adjacency lists *)
+
+module type Hashconsed =
+sig
+  type t
+  val hash : t -> int
+  val equal : t -> t -> bool
+  val hcons : t -> t
+end
+
+module HashedList (M : Hashconsed) :
+sig
+  type t = private Nil | Cons of M.t * int * t
+  val nil : t
+  val cons : M.t -> t -> t
+end =
+struct
+  type t = Nil | Cons of M.t * int * t
+  module Self =
+  struct
+    type _t = t
+    type t = _t
+    type u = (M.t -> M.t)
+    let hash = function Nil -> 0 | Cons (_, h, _) -> h
+    let equal l1 l2 = match l1, l2 with
+    | Nil, Nil -> true
+    | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2
+    | _ -> false
+    let hashcons hc = function
+    | Nil -> Nil
+    | Cons (x, h, l) -> Cons (hc x, h, l)
+  end
+  module Hcons = Hashcons.Make(Self)
+  let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons
+  (** No recursive call: the interface guarantees that all HLists from this
+      program are already hashconsed. If we get some external HList, we can
+      still reconstruct it by traversing it entirely. *)
+  let nil = Nil
+  let cons x l =
+    let h = M.hash x in
+    let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in
+    let h = Hashset.Combine.combine h hl in
+    hcons (Cons (x, h, l))
+end
+
+module HList = struct
+
+  module type S = sig
+    type elt
+    type t = private Nil | Cons of elt * int * t
+    val hash : t -> int
+    val nil : t
+    val cons : elt -> t -> t
+    val tip : elt -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val map : (elt -> elt) -> t -> t
+    val smartmap : (elt -> elt) -> t -> t
+    val exists : (elt -> bool) -> t -> bool
+    val for_all : (elt -> bool) -> t -> bool
+    val for_all2 : (elt -> elt -> bool) -> t -> t -> bool
+    val remove : elt -> t -> t
+    val to_list : t -> elt list
+  end
+
+  module Make (H : Hashconsed) : S with type elt = H.t =
+  struct
+  type elt = H.t
+  include HashedList(H)
+
+  let hash = function Nil -> 0 | Cons (_, h, _) -> h
+
+  let tip e = cons e nil
+
+  let rec fold f l accu = match l with
+  | Nil -> accu
+  | Cons (x, _, l) -> fold f l (f x accu)
+
+  let rec map f = function
+  | Nil -> nil
+  | Cons (x, _, l) -> cons (f x) (map f l)
+
+  let smartmap = map
+  (** Apriori hashconsing ensures that the map is equal to its argument *)
+
+  let rec exists f = function
+  | Nil -> false
+  | Cons (x, _, l) -> f x || exists f l
+
+  let rec for_all f = function
+  | Nil -> true
+  | Cons (x, _, l) -> f x && for_all f l
+
+  let rec for_all2 f l1 l2 = match l1, l2 with
+  | Nil, Nil -> true
+  | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2
+  | _ -> false
+
+  let rec to_list = function
+  | Nil -> []
+  | Cons (x, _, l) -> x :: to_list l
+
+  let rec remove x = function
+  | Nil -> nil
+  | Cons (y, _, l) ->
+    if H.equal x y then l
+    else cons y (remove x l)
+
+  end
+end
+
+module RawLevel =
+struct
+  open Names
+  type t =
+    | Prop
+    | Set
+    | Level of int * DirPath.t
+    | Var of int
+
+  (* Hash-consing *)
+
+  let equal x y =
+    x == y ||
+      match x, y with
+      | Prop, Prop -> true
+      | Set, Set -> true
+      | Level (n,d), Level (n',d') ->
+        Int.equal n n' && DirPath.equal d d'
+      | Var n, Var n' -> Int.equal n n'
+      | _ -> false
+
+  let compare u v =
+    match u, v with
+    | Prop,Prop -> 0
+    | Prop, _ -> -1
+    | _, Prop -> 1
+    | Set, Set -> 0
+    | Set, _ -> -1
+    | _, Set -> 1
+    | Level (i1, dp1), Level (i2, dp2) ->
+      if i1 < i2 then -1
+      else if i1 > i2 then 1
+      else DirPath.compare dp1 dp2
+    | Level _, _ -> -1
+    | _, Level _ -> 1
+    | Var n, Var m -> Int.compare n m
+
+  let hcons = function
+    | Prop as x -> x
+    | Set as x -> x
+    | Level (n,d) as x -> 
+      let d' = Names.DirPath.hcons d in
+        if d' == d then x else Level (n,d')
+    | Var n as x -> x
+
+  open Hashset.Combine
+
+  let hash = function
+    | Prop -> combinesmall 1 0
+    | Set -> combinesmall 1 1
+    | Var n -> combinesmall 2 n
+    | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d))
+end
+
+module Level = struct
+
+  open Names
+
+  type raw_level = RawLevel.t =
+  | Prop
+  | Set
+  | Level of int * DirPath.t
+  | Var of int
+
+  (** Embed levels with their hash value *)
+  type t = { 
+    hash : int;
+    data : RawLevel.t }
+
+  let equal x y = 
+    x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data
+
+  let hash x = x.hash
+
+  let hcons x = 
+    let data' = RawLevel.hcons x.data in
+      if data' == x.data then x
+      else { x with data = data' }
+
+  let data x = x.data
+
+  (** Hashcons on levels + their hash *)
+
+  let make =
+    let module Self = struct
+      type _t = t
+      type t = _t
+      let equal = equal
+      let hash = hash
+    end in
+    let module WH = Weak.Make(Self) in
+    let pool = WH.create 4910 in fun x ->
+    let x = { hash = RawLevel.hash x; data = x } in
+    try WH.find pool x
+    with Not_found -> WH.add pool x; x
+
+  let set = make Set
+  let prop = make Prop
+
+  let is_small x = 
+    match data x with
+    | Level _ -> false
+    | _ -> true
+
+  let is_prop x =
+    match data x with
+    | Prop -> true
+    | _ -> false
+
+  let is_set x =
+    match data x with
+    | Set -> true
+    | _ -> false
+
+  let compare u v =
+    if u == v then 0
+    else
+      let c = Int.compare (hash u) (hash v) in
+	if c == 0 then RawLevel.compare (data u) (data v)
+	else c
+	    
+  let to_string x = 
+    match data x with
+    | Prop -> "Prop"
+    | Set -> "Set"
+    | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n
+    | Var i -> "Var("^string_of_int i^")"
+
+  let pr u = str (to_string u)
+
+  let make m n = make (Level (n, Names.DirPath.hcons m))
+
+end
+
+(** Level sets and maps *)
+module LSet = Set.Make (Level)
+module LMap = Map.Make (Level)
+
+type 'a universe_map = 'a LMap.t
+
+type universe_level = Level.t
+
+type universe_level_subst_fn = universe_level -> universe_level
+
+(* An algebraic universe [universe] is either a universe variable
+   [Level.t] or a formal universe known to be greater than some
+   universe variables and strictly greater than some (other) universe
+   variables
+
+   Universes variables denote universes initially present in the term
+   to type-check and non variable algebraic universes denote the
+   universes inferred while type-checking: it is either the successor
+   of a universe present in the initial term to type-check or the
+   maximum of two algebraic universes
+*)
+
+module Universe =
+struct
+  (* Invariants: non empty, sorted and without duplicates *)
+
+  module Expr = 
+  struct
+    type t = Level.t * int
+    type _t = t
+	
+    (* Hashing of expressions *)
+    module ExprHash = 
+    struct
+      type t = _t
+      type u = Level.t -> Level.t
+      let hashcons hdir (b,n as x) = 
+	let b' = hdir b in 
+	  if b' == b then x else (b',n)
+      let equal l1 l2 =
+        l1 == l2 || 
+        match l1,l2 with
+	| (b,n), (b',n') -> b == b' && n == n'
+
+      let hash (x, n) = n + Level.hash x
+
+    end
+
+    module HExpr =
+    struct
+
+      module H = Hashcons.Make(ExprHash)
+
+      type t = ExprHash.t
+
+      let hcons =
+        Hashcons.simple_hcons H.generate H.hcons Level.hcons
+      let hash = ExprHash.hash
+      let equal x y = x == y ||
+        (let (u,n) = x and (v,n') = y in
+           Int.equal n n' && Level.equal u v)
+
+    end
+
+    let hcons = HExpr.hcons
+
+    let make l = hcons (l, 0)
+
+    let prop = make Level.prop
+    let set = make Level.set
+    let type1 = hcons (Level.set, 1)
+
+    let is_prop = function
+      | (l,0) -> Level.is_prop l
+      | _ -> false
+
+    let equal x y = x == y ||
+      (let (u,n) = x and (v,n') = y in
+	 Int.equal n n' && Level.equal u v)
+
+    let leq (u,n) (v,n') =
+      let cmp = Level.compare u v in
+	if Int.equal cmp 0 then n <= n'
+	else if n <= n' then 
+	  (Level.is_prop u && Level.is_small v)
+	else false
+
+    let successor (u,n) =
+      if Level.is_prop u then type1
+      else hcons (u, n + 1)
+
+    let addn k (u,n as x) = 
+      if k = 0 then x 
+      else if Level.is_prop u then
+	hcons (Level.set,n+k)
+      else hcons (u,n+k)
+	
+    let super (u,n as x) (v,n' as y) =
+      let cmp = Level.compare u v in
+	if Int.equal cmp 0 then 
+	  if n < n' then Inl true
+	  else Inl false
+	else if is_prop x then Inl true
+	else if is_prop y then Inl false
+	else Inr cmp
+
+    let to_string (v, n) =
+      if Int.equal n 0 then Level.to_string v
+      else Level.to_string v ^ "+" ^ string_of_int n
+
+    let pr x = str(to_string x)
+
+    let level = function
+      | (v,0) -> Some v
+      | _ -> None
+
+    let map f (v, n as x) = 
+      let v' = f v in 
+	if v' == v then x
+	else if Level.is_prop v' && n != 0 then
+	  hcons (Level.set, n)
+	else hcons (v', n)
+
+  end
+    
+  module Huniv = HList.Make(Expr.HExpr)
+  type t = Huniv.t
+  open Huniv
+    
+  let equal x y = x == y || 
+    (Huniv.hash x == Huniv.hash y && 
+       Huniv.for_all2 Expr.equal x y)
+
+  let make l = Huniv.tip (Expr.make l)
+  let tip x = Huniv.tip x
+    
+  let pr l = match l with
+    | Cons (u, _, Nil) -> Expr.pr u
+    | _ -> 
+      str "max(" ++ hov 0
+	(prlist_with_sep pr_comma Expr.pr (to_list l)) ++
+        str ")"
+
+  let level l = match l with
+    | Cons (l, _, Nil) -> Expr.level l
+    | _ -> None
+
+  (* The lower predicative level of the hierarchy that contains (impredicative)
+     Prop and singleton inductive types *)
+  let type0m = tip Expr.prop
+
+  (* The level of sets *)
+  let type0 = tip Expr.set
+
+  (* When typing [Prop] and [Set], there is no constraint on the level,
+     hence the definition of [type1_univ], the type of [Prop] *)    
+  let type1 = tip (Expr.successor Expr.set)
+
+  let is_type0m x = equal type0m x
+  let is_type0 x = equal type0 x
+
+  (* Returns the formal universe that lies juste above the universe variable u.
+     Used to type the sort u. *)
+  let super l = 
+    Huniv.map (fun x -> Expr.successor x) l
+
+  let addn n l =
+    Huniv.map (fun x -> Expr.addn n x) l
+
+  let rec merge_univs l1 l2 =
+    match l1, l2 with
+    | Nil, _ -> l2
+    | _, Nil -> l1
+    | Cons (h1, _, t1), Cons (h2, _, t2) ->
+      (match Expr.super h1 h2 with
+      | Inl true (* h1 < h2 *) -> merge_univs t1 l2
+      | Inl false -> merge_univs l1 t2
+      | Inr c -> 
+        if c <= 0 (* h1 < h2 is name order *)
+	then cons h1 (merge_univs t1 l2)
+	else cons h2 (merge_univs l1 t2))
+
+  let sort u =
+    let rec aux a l = 
+      match l with
+      | Cons (b, _, l') ->
+        (match Expr.super a b with
+	| Inl false -> aux a l'
+	| Inl true -> l
+	| Inr c ->
+	  if c <= 0 then cons a l
+	  else cons b (aux a l'))
+      | Nil -> cons a l
+    in 
+      fold (fun a acc -> aux a acc) u nil
+	
+  (* Returns the formal universe that is greater than the universes u and v.
+     Used to type the products. *)
+  let sup x y = merge_univs x y
+
+  let empty = nil
+
+  let exists = Huniv.exists
+
+  let for_all = Huniv.for_all
+
+  let smartmap = Huniv.smartmap
+
+end
+
+type universe = Universe.t
+
+(* The level of predicative Set *)
+let type0m_univ = Universe.type0m
+let type0_univ = Universe.type0
+let type1_univ = Universe.type1
+let is_type0m_univ = Universe.is_type0m
+let is_type0_univ = Universe.is_type0
+let is_univ_variable l = Universe.level l != None
+let pr_uni = Universe.pr
+
+let sup = Universe.sup
+let super = Universe.super
+
+open Universe
+
+(* Comparison on this type is pointer equality *)
+type canonical_arc =
+    { univ: Level.t;
+      lt: Level.t list;
+      le: Level.t list;
+      rank : int;
+      predicative : bool}
+
+let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false}
+
+module UMap :
+sig
+  type key = Level.t
+  type +'a t
+  val empty : 'a t
+  val add : key -> 'a -> 'a t -> 'a t
+  val find : key -> 'a t -> 'a
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end = HMap.Make(Level)
+
+(* A Level.t is either an alias for another one, or a canonical one,
+   for which we know the universes that are above *)
+
+type univ_entry =
+    Canonical of canonical_arc
+  | Equiv of Level.t
+
+type universes = univ_entry UMap.t
+
+let enter_equiv_arc u v g =
+  UMap.add u (Equiv v) g
+
+let enter_arc ca g =
+  UMap.add ca.univ (Canonical ca) g
+
+(* Every Level.t has a unique canonical arc representative *)
+
+(* repr : universes -> Level.t -> canonical_arc *)
+(* canonical representative : we follow the Equiv links *)
+
+let repr g u =
+  let rec repr_rec u =
+    let a =
+      try UMap.find u g
+      with Not_found -> anomaly ~label:"Univ.repr"
+	  (str"Universe " ++ Level.pr u ++ str" undefined")
+    in
+    match a with
+      | Equiv v -> repr_rec v
+      | Canonical arc -> arc
+  in
+  repr_rec u
+
+(* [safe_repr] also search for the canonical representative, but
+   if the graph doesn't contain the searched universe, we add it. *)
+
+let safe_repr g u =
+  let rec safe_repr_rec u =
+    match UMap.find u g with
+      | Equiv v -> safe_repr_rec v
+      | Canonical arc -> arc
+  in
+  try g, safe_repr_rec u
+  with Not_found ->
+    let can = terminal u in
+    enter_arc can g, can
+
+(* reprleq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
+let reprleq g arcu =
+  let rec searchrec w = function
+    | [] -> w
+    | v :: vl ->
+	let arcv = repr g v in
+        if List.memq arcv w || arcu==arcv then
+	  searchrec w vl
+        else
+	  searchrec (arcv :: w) vl
+  in
+  searchrec [] arcu.le
+
+
+(* between : Level.t -> canonical_arc -> canonical_arc list *)
+(* between u v = { w | u<=w<=v, w canonical }          *)
+(* between is the most costly operation *)
+
+let between g arcu arcv =
+  (* good are all w | u <= w <= v  *)
+  (* bad are all w | u <= w ~<= v *)
+    (* find good and bad nodes in {w | u <= w} *)
+    (* explore b u = (b or "u is good") *)
+  let rec explore ((good, bad, b) as input) arcu =
+    if List.memq arcu good then
+      (good, bad, true) (* b or true *)
+    else if List.memq arcu bad then
+      input    (* (good, bad, b or false) *)
+    else
+      let leq = reprleq g arcu in
+	(* is some universe >= u good ? *)
+      let good, bad, b_leq =
+	List.fold_left explore (good, bad, false) leq
+      in
+	if b_leq then
+	  arcu::good, bad, true (* b or true *)
+	else
+	  good, arcu::bad, b    (* b or false *)
+  in
+  let good,_,_ = explore ([arcv],[],false) arcu in
+    good
+
+(* We assume  compare(u,v) = LE with v canonical (see compare below).
+   In this case List.hd(between g u v) = repr u
+   Otherwise, between g u v = []
+ *)
+
+type constraint_type = Lt | Le | Eq
+
+let constraint_type_ord c1 c2 = match c1, c2 with
+| Lt, Lt -> 0
+| Lt, _ -> -1
+| Le, Lt -> 1
+| Le, Le -> 0
+| Le, Eq -> -1
+| Eq, Eq -> 0
+| Eq, _ -> 1
+
+(** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
+
+  In [strict] mode, we fully distinguish between LE and LT, while in
+  non-strict mode, we simply answer LE for both situations.
+
+  If [arcv] is encountered in a LT part, we could directly answer
+  without visiting unneeded parts of this transitive closure.
+  In [strict] mode, if [arcv] is encountered in a LE part, we could only
+  change the default answer (1st arg [c]) from NLE to LE, since a strict
+  constraint may appear later. During the recursive traversal,
+  [lt_done] and [le_done] are universes we have already visited,
+  they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)],
+  two lists of universes not yet considered, known to be above [arcu],
+  strictly or not.
+
+  We use depth-first search, but the presence of [arcv] in [new_lt]
+  is checked as soon as possible : this seems to be slightly faster
+  on a test.
+*)
+
+type fast_order = FastEQ | FastLT | FastLE | FastNLE
+
+let fast_compare_neq strict g arcu arcv =
+  (* [c] characterizes whether arcv has already been related
+     to arcu among the lt_done,le_done universe *)
+  let rec cmp c lt_done le_done lt_todo le_todo = match lt_todo, le_todo with
+  | [],[] -> c
+  | arc::lt_todo, le_todo ->
+    if List.memq arc lt_done then
+      cmp c lt_done le_done lt_todo le_todo
+    else
+      let rec find lt_todo lt le = match le with
+      | [] ->
+        begin match lt with
+        | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then FastLT else FastLE
+          else find (arc :: lt_todo) lt le
+        end
+      | u :: le ->
+        let arc = repr g u in
+        if arc == arcv then
+          if strict then FastLT else FastLE
+        else find (arc :: lt_todo) lt le
+      in
+      find lt_todo arc.lt arc.le
+  | [], arc::le_todo ->
+    if arc == arcv then
+      (* No need to continue inspecting universes above arc:
+	 if arcv is strictly above arc, then we would have a cycle.
+         But we cannot answer LE yet, a stronger constraint may
+	 come later from [le_todo]. *)
+      if strict then cmp FastLE lt_done le_done [] le_todo else FastLE
+    else
+      if (List.memq arc lt_done) || (List.memq arc le_done) then
+        cmp c lt_done le_done [] le_todo
+      else
+        let rec find lt_todo lt = match lt with
+        | [] ->
+          let fold accu u =
+            let node = repr g u in
+            node :: accu
+          in
+          let le_new = List.fold_left fold le_todo arc.le in
+          cmp c lt_done (arc :: le_done) lt_todo le_new
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then FastLT else FastLE
+          else find (arc :: lt_todo) lt
+        in
+        find [] arc.lt
+  in
+  cmp FastNLE [] [] [] [arcu]
+
+let fast_compare g arcu arcv =
+  if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv
+
+let is_leq g arcu arcv =
+  arcu == arcv ||
+    (match fast_compare_neq false g arcu arcv with
+    | FastNLE -> false
+    | (FastEQ|FastLE|FastLT) -> true)
+    
+let is_lt g arcu arcv =
+  if arcu == arcv then false
+  else
+    match fast_compare_neq true g arcu arcv with
+    | FastLT -> true
+    | (FastEQ|FastLE|FastNLE) -> false
+
+(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
+                compare(u,v) = LT or LE => compare(v,u) = NLE
+                compare(u,v) = NLE => compare(v,u) = NLE or LE or LT
+
+   Adding u>=v is consistent iff compare(v,u) # LT
+    and then it is redundant iff compare(u,v) # NLE
+   Adding u>v is consistent iff compare(v,u) = NLE
+    and then it is redundant iff compare(u,v) = LT *)
+
+(** * Universe checks [check_eq] and [check_leq], used in coqchk *)
+
+(** First, checks on universe levels *)
+
+let check_equal g u v =
+  let g, arcu = safe_repr g u in
+  let _, arcv = safe_repr g v in
+  arcu == arcv
+
+let check_eq_level g u v = u == v || check_equal g u v
+
+let is_set_arc u = Level.is_set u.univ
+let is_prop_arc u = Level.is_prop u.univ
+
+let check_smaller g strict u v =
+  let g, arcu = safe_repr g u in
+  let g, arcv = safe_repr g v in
+  if strict then
+    is_lt g arcu arcv
+  else
+    is_prop_arc arcu 
+    || (is_set_arc arcu && arcv.predicative) 
+    || is_leq g arcu arcv
+
+(** Then, checks on universes *)
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+
+let check_equal_expr g x y =
+  x == y || (let (u, n) = x and (v, m) = y in 
+	       Int.equal n m && check_equal g u v)
+
+let check_eq_univs g l1 l2 =
+  let f x1 x2 = check_equal_expr g x1 x2 in
+  let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in
+    Huniv.for_all (fun x1 -> exists x1 l2) l1
+    && Huniv.for_all (fun x2 -> exists x2 l1) l2
+
+let check_eq g u v =
+  Universe.equal u v || check_eq_univs g u v
+
+let check_smaller_expr g (u,n) (v,m) =
+  let diff = n - m in
+    match diff with
+    | 0 -> check_smaller g false u v
+    | 1 -> check_smaller g true u v
+    | x when x < 0 -> check_smaller g false u v
+    | _ -> false
+
+let exists_bigger g ul l =
+  Huniv.exists (fun ul' -> 
+    check_smaller_expr g ul ul') l
+
+let real_check_leq g u v =
+  Huniv.for_all (fun ul -> exists_bigger g ul v) u
+    
+let check_leq g u v =
+  Universe.equal u v ||
+    Universe.is_type0m u ||
+    check_eq_univs g u v || real_check_leq g u v
+
+(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
+
+(** To speed up tests of Set </<= i *)
+let set_predicative g arcv = 
+  enter_arc {arcv with predicative = true} g
+
+(* setlt : Level.t -> Level.t -> reason -> unit *)
+(* forces u > v *)
+(* this is normally an update of u in g rather than a creation. *)
+let setlt g arcu arcv =
+  let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
+  let g = 
+    if is_set_arc arcu then set_predicative g arcv
+    else g
+  in
+    enter_arc arcu' g, arcu'
+
+(* checks that non-redundant *)
+let setlt_if (g,arcu) v =
+  let arcv = repr g v in
+  if is_lt g arcu arcv then g, arcu
+  else setlt g arcu arcv
+
+(* setleq : Level.t -> Level.t -> unit *)
+(* forces u >= v *)
+(* this is normally an update of u in g rather than a creation. *)
+let setleq g arcu arcv =
+  let arcu' = {arcu with le=arcv.univ::arcu.le} in
+  let g = 
+    if is_set_arc arcu' then
+      set_predicative g arcv
+    else g
+  in
+    enter_arc arcu' g, arcu'
+
+(* checks that non-redundant *)
+let setleq_if (g,arcu) v =
+  let arcv = repr g v in
+  if is_leq g arcu arcv then g, arcu
+  else setleq g arcu arcv
+
+(* merge : Level.t -> Level.t -> unit *)
+(* we assume  compare(u,v) = LE *)
+(* merge u v  forces u ~ v with repr u as canonical repr *)
+let merge g arcu arcv =
+  (* we find the arc with the biggest rank, and we redirect all others to it *)
+  let arcu, g, v =
+    let best_ranked (max_rank, old_max_rank, best_arc, rest) arc =
+      if Level.is_small arc.univ || arc.rank >= max_rank
+      then (arc.rank, max_rank, arc, best_arc::rest)
+      else (max_rank, old_max_rank, best_arc, arc::rest)
+    in
+      match between g arcu arcv with
+      | [] -> anomaly (str "Univ.between")
+      | arc::rest ->
+        let (max_rank, old_max_rank, best_arc, rest) =
+          List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in
+          if max_rank > old_max_rank then best_arc, g, rest
+          else begin
+              (* one redirected node also has max_rank *)
+            let arcu = {best_arc with rank = max_rank + 1} in
+	      arcu, enter_arc arcu g, rest
+          end 
+  in
+  let redirect (g,w,w') arcv =
+    let g' = enter_equiv_arc arcv.univ arcu.univ g in
+    (g',List.unionq arcv.lt w,arcv.le@w')
+  in
+  let (g',w,w') = List.fold_left redirect (g,[],[]) v in
+  let g_arcu = (g',arcu) in
+  let g_arcu = List.fold_left setlt_if g_arcu w in
+  let g_arcu = List.fold_left setleq_if g_arcu w' in
+  fst g_arcu
+
+(* merge_disc : Level.t -> Level.t -> unit *)
+(* we assume  compare(u,v) = compare(v,u) = NLE *)
+(* merge_disc u v  forces u ~ v with repr u as canonical repr *)
+let merge_disc g arc1 arc2 =
+  let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in
+  let arcu, g = 
+    if not (Int.equal arc1.rank arc2.rank) then arcu, g
+    else
+      let arcu = {arcu with rank = succ arcu.rank} in 
+      arcu, enter_arc arcu g
+  in
+  let g' = enter_equiv_arc arcv.univ arcu.univ g in
+  let g_arcu = (g',arcu) in
+  let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
+  let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
+  fst g_arcu
+
+(* Universe inconsistency: error raised when trying to enforce a relation
+   that would create a cycle in the graph of universes. *)
+
+type univ_inconsistency = constraint_type * universe * universe
+
+exception UniverseInconsistency of univ_inconsistency
+
+let error_inconsistency o u v =
+  raise (UniverseInconsistency (o,make u,make v))
+
+(* enforc_univ_eq : Level.t -> Level.t -> unit *)
+(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
+
+let enforce_univ_eq u v g =
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+    match fast_compare g arcu arcv with
+    | FastEQ -> g
+    | FastLT -> error_inconsistency Eq v u
+    | FastLE -> merge g arcu arcv
+    | FastNLE ->
+      (match fast_compare g arcv arcu with
+      | FastLT -> error_inconsistency Eq u v
+      | FastLE -> merge g arcv arcu
+      | FastNLE -> merge_disc g arcu arcv
+      | FastEQ -> anomaly (Pp.str "Univ.compare"))
+
+(* enforce_univ_leq : Level.t -> Level.t -> unit *)
+(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
+let enforce_univ_leq u v g =
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  if is_leq g arcu arcv then g
+  else
+    match fast_compare g arcv arcu with
+    | FastLT -> error_inconsistency Le u v
+    | FastLE  -> merge g arcv arcu
+    | FastNLE -> fst (setleq g arcu arcv)
+    | FastEQ -> anomaly (Pp.str "Univ.compare")
+
+(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
+let enforce_univ_lt u v g =
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+    match fast_compare g arcu arcv with
+    | FastLT -> g
+    | FastLE -> fst (setlt g arcu arcv)
+    | FastEQ -> error_inconsistency Lt u v
+    | FastNLE ->
+      match fast_compare_neq false g arcv arcu with
+	FastNLE -> fst (setlt g arcu arcv)
+      | FastEQ -> anomaly (Pp.str "Univ.compare")
+      | FastLE | FastLT -> error_inconsistency Lt u v
+
+(* Prop = Set is forbidden here. *)
+let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty
+
+(* Constraints and sets of constraints. *)    
+
+type univ_constraint = Level.t * constraint_type * Level.t
+
+let enforce_constraint cst g =
+  match cst with
+    | (u,Lt,v) -> enforce_univ_lt u v g
+    | (u,Le,v) -> enforce_univ_leq u v g
+    | (u,Eq,v) -> enforce_univ_eq u v g
+
+module UConstraintOrd =
+struct
+  type t = univ_constraint
+  let compare (u,c,v) (u',c',v') =
+    let i = constraint_type_ord c c' in
+    if not (Int.equal i 0) then i
+    else
+      let i' = Level.compare u u' in
+      if not (Int.equal i' 0) then i'
+      else Level.compare v v'
+end
+
+module Constraint = Set.Make(UConstraintOrd)
+
+let empty_constraint = Constraint.empty
+let merge_constraints c g =
+  Constraint.fold enforce_constraint c g
+
+type constraints = Constraint.t
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
+
+(** Constraint functions. *)
+
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+let constraint_add_leq v u c =
+  (* We just discard trivial constraints like u<=u *)
+  if Expr.equal v u then c
+  else 
+    match v, u with
+    | (x,n), (y,m) -> 
+    let j = m - n in
+      if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then
+	Constraint.add (x,Lt,y) c
+      else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then
+	if Level.equal x y then (* u+(k+1) <= u *)
+	  raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u))
+	else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints")
+      else if j = 0 then
+	Constraint.add (x,Le,y) c
+      else (* j >= 1 *) (* m = n + k, u <= v+k *)
+	if Level.equal x y then c (* u <= u+k, trivial *)
+	else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *)
+	else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints")
+	  
+let check_univ_leq_one u v = Universe.exists (Expr.leq u) v
+
+let check_univ_leq u v = 
+  Universe.for_all (fun u -> check_univ_leq_one u v) u
+
+let enforce_leq u v c =
+  match v with
+  | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) ->
+    Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c
+  | _ -> anomaly (Pp.str"A universe bound can only be a variable")
+
+let enforce_leq u v c =
+  if check_univ_leq u v then c
+  else enforce_leq u v c
+
+let check_constraint g (l,d,r) =
+  match d with
+  | Eq -> check_equal g l r
+  | Le -> check_smaller g false l r
+  | Lt -> check_smaller g true l r
+
+let check_constraints c g =
+  Constraint.for_all (check_constraint g) c
+
+(**********************************************************************)
+(** Universe polymorphism                                             *)
+(**********************************************************************)
+
+(** A universe level substitution, note that no algebraic universes are
+    involved *)
+
+type universe_level_subst = universe_level universe_map
+
+(** A full substitution might involve algebraic universes *)
+type universe_subst = universe universe_map
+
+let level_subst_of f = 
+  fun l -> 
+    try let u = f l in 
+	  match Universe.level u with
+	  | None -> l
+	  | Some l -> l
+    with Not_found -> l
+     
+module Instance : sig 
+    type t = Level.t array
+
+    val empty : t
+    val is_empty : t -> bool
+    val equal : t -> t -> bool
+    val subst_fn : universe_level_subst_fn -> t -> t
+    val subst : universe_level_subst -> t -> t
+    val pr : t -> Pp.std_ppcmds
+    val check_eq : t check_function 
+end = 
+struct
+  type t = Level.t array
+
+  let empty : t = [||]
+
+  module HInstancestruct =
+  struct
+    type _t = t
+    type t = _t
+    type u = Level.t -> Level.t
+
+    let hashcons huniv a = 
+      let len = Array.length a in
+	if Int.equal len 0 then empty
+	else begin
+	  for i = 0 to len - 1 do
+	    let x = Array.unsafe_get a i in
+	    let x' = huniv x in
+	      if x == x' then ()
+	      else Array.unsafe_set a i x'
+	  done;
+	  a
+	end
+
+    let equal t1 t2 =
+      t1 == t2 ||
+	(Int.equal (Array.length t1) (Array.length t2) &&
+	   let rec aux i =
+	     (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1))
+	   in aux 0)
+	
+    let hash a = 
+      let accu = ref 0 in
+	for i = 0 to Array.length a - 1 do
+	  let l = Array.unsafe_get a i in
+	  let h = Level.hash l in
+	    accu := Hashset.Combine.combine !accu h;
+	done;
+	(* [h] must be positive. *)
+	let h = !accu land 0x3FFFFFFF in
+	  h
+  end
+
+  module HInstance = Hashcons.Make(HInstancestruct)
+
+  let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons
+    
+  let empty = hcons [||]
+
+  let is_empty x = Int.equal (Array.length x) 0
+
+  let subst_fn fn t = 
+    let t' = CArray.smartmap fn t in
+      if t' == t then t else hcons t'
+
+  let subst s t =
+    let t' = 
+      CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t
+    in if t' == t then t else hcons t'
+
+  let pr =
+    prvect_with_sep spc Level.pr
+
+  let equal t u = 
+    t == u ||
+      (Array.is_empty t && Array.is_empty u) ||
+      (CArray.for_all2 Level.equal t u 
+	 (* Necessary as universe instances might come from different modules and 
+	    unmarshalling doesn't preserve sharing *))
+
+  let check_eq g t1 t2 =
+    t1 == t2 ||
+      (Int.equal (Array.length t1) (Array.length t2) &&
+	 let rec aux i =
+	   (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1))
+	 in aux 0)
+
+end
+
+type universe_instance = Instance.t
+
+type 'a puniverses = 'a * Instance.t
+(** A context of universe levels with universe constraints,
+    representiong local universe variables and constraints *)
+
+module UContext =
+struct
+  type t = Instance.t constrained
+
+  (** Universe contexts (variables as a list) *)
+  let empty = (Instance.empty, Constraint.empty)
+
+  let instance (univs, cst) = univs
+  let constraints (univs, cst) = cst
+end
+
+type universe_context = UContext.t
+
+module ContextSet =
+struct
+  type t = LSet.t constrained
+  let empty = LSet.empty, Constraint.empty
+  let constraints (_, cst) = cst
+end
+type universe_context_set = ContextSet.t
+
+(** Substitutions. *)
+
+let is_empty_subst = LMap.is_empty
+let empty_level_subst = LMap.empty
+let is_empty_level_subst = LMap.is_empty
+
+(** Substitution functions *)
+
+(** With level to level substitutions. *)
+let subst_univs_level_level subst l =
+  try LMap.find l subst
+  with Not_found -> l
+
+let subst_univs_level_universe subst u =
+  let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in
+  let u' = Universe.smartmap f u in
+    if u == u' then u
+    else Universe.sort u'
+
+(** Substitute instance inst for ctx in csts *)
+
+let subst_instance_level s l =
+  match l.Level.data with
+  | Level.Var n -> s.(n) 
+  | _ -> l
+
+let subst_instance_instance s i = 
+  Array.smartmap (fun l -> subst_instance_level s l) i
+
+let subst_instance_universe s u =
+  let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in
+  let u' = Universe.smartmap f u in
+    if u == u' then u
+    else Universe.sort u'
+
+let subst_instance_constraint s (u,d,v as c) =
+  let u' = subst_instance_level s u in
+  let v' = subst_instance_level s v in
+    if u' == u && v' == v then c
+    else (u',d,v')
+
+let subst_instance_constraints s csts =
+  Constraint.fold 
+    (fun c csts -> Constraint.add (subst_instance_constraint s c) csts)
+    csts Constraint.empty 
+
+(** Substitute instance inst for ctx in csts *)
+let instantiate_univ_context (ctx, csts) = 
+  (ctx, subst_instance_constraints ctx csts)
+
+let instantiate_univ_constraints u (_, csts) = 
+  subst_instance_constraints u csts
+
+(** With level to universe substitutions. *)
+type universe_subst_fn = universe_level -> universe
+
+let make_subst subst = fun l -> LMap.find l subst
+
+let subst_univs_expr_opt fn (l,n) =
+  Universe.addn n (fn l)
+
+let subst_univs_universe fn ul =
+  let subst, nosubst = 
+    Universe.Huniv.fold (fun u (subst,nosubst) -> 
+      try let a' = subst_univs_expr_opt fn u in
+	    (a' :: subst, nosubst)
+      with Not_found -> (subst, u :: nosubst))
+      ul ([], [])
+  in 
+    if CList.is_empty subst then ul
+    else 
+      let substs = 
+	List.fold_left Universe.merge_univs Universe.empty subst
+      in
+	List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u))
+	  substs nosubst
+
+(** Pretty-printing *)
+
+let pr_arc = function
+  | _, Canonical {univ=u; lt=[]; le=[]} ->
+      mt ()
+  | _, Canonical {univ=u; lt=lt; le=le} ->
+      let opt_sep = match lt, le with
+      | [], _ | _, [] -> mt ()
+      | _ -> spc ()
+      in
+      Level.pr u ++ str " " ++
+      v 0
+        (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++
+	 opt_sep ++
+         pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++
+      fnl ()
+  | u, Equiv v ->
+      Level.pr u  ++ str " = " ++ Level.pr v ++ fnl ()
+
+let pr_universes g =
+  let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in
+  prlist pr_arc graph
diff --git a/checker/univ.mli b/checker/univ.mli
new file mode 100644
index 00000000..742ef91a
--- /dev/null
+++ b/checker/univ.mli
@@ -0,0 +1,224 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Universes. *)
+
+module Level :
+sig
+  type t
+  (** Type of universe levels. A universe level is essentially a unique name
+      that will be associated to constraints later on. *)
+
+  val make : Names.DirPath.t -> int -> t
+  (** Create a new universe level from a unique identifier and an associated
+      module path. *)
+
+  val equal : t -> t -> bool
+end
+
+type universe_level = Level.t
+(** Alias name. *)
+
+module Universe :
+sig
+  type t
+  (** Type of universes. A universe is defined as a set of level expressions.
+      A level expression is built from levels and successors of level expressions, i.e.:
+      le ::= l + n, n \in N.
+
+      A universe is said atomic if it consists of a single level expression with
+      no increment, and algebraic otherwise (think the least upper bound of a set of
+      level expressions).
+  *)
+
+  val equal : t -> t -> bool
+  (** Equality function on formal universes *)
+
+  val make : Level.t -> t
+  (** Create a universe representing the given level. *)
+
+end
+
+type universe = Universe.t
+
+(** Alias name. *)
+
+val pr_uni : universe -> Pp.std_ppcmds
+
+(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ...
+   Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+val type0m_univ : universe
+val type0_univ : universe
+val type1_univ : universe
+
+val is_type0_univ : universe -> bool
+val is_type0m_univ : universe -> bool
+val is_univ_variable : universe -> bool
+
+val sup : universe -> universe -> universe
+val super : universe -> universe
+
+(** {6 Graphs of universes. } *)
+
+type universes
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+val check_leq : universe check_function
+val check_eq : universe check_function
+
+(** The initial graph of universes: Prop < Set *)
+val initial_universes : universes
+
+(** {6 Constraints. } *)
+
+type constraint_type = Lt | Le | Eq
+type univ_constraint = universe_level * constraint_type * universe_level
+
+module Constraint : Set.S with type elt = univ_constraint
+
+type constraints = Constraint.t
+
+val empty_constraint : constraints
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
+
+(** Enforcing constraints. *)
+
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+val enforce_leq : universe constraint_function
+
+(** {6 ... } *)
+(** Merge of constraints in a universes graph.
+  The function [merge_constraints] merges a set of constraints in a given
+  universes graph. It raises the exception [UniverseInconsistency] if the
+  constraints are not satisfiable. *)
+
+(** Type explanation is used to decorate error messages to provide
+  useful explanation why a given constraint is rejected. It is composed
+  of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means
+   .. <(r1) u1 <(r2) ... <(rn) un (where <(ri) is the relation symbol
+  denoted by ri, currently only < and <=). The lowest end of the chain
+  is supposed known (see UniverseInconsistency exn). The upper end may
+  differ from the second univ of UniverseInconsistency because all
+  universes in the path are canonical. Note that each step does not
+  necessarily correspond to an actual constraint, but reflect how the
+  system stores the graph and may result from combination of several
+  constraints...
+*)
+type univ_inconsistency = constraint_type * universe * universe
+
+exception UniverseInconsistency of univ_inconsistency
+
+val merge_constraints : constraints -> universes -> universes
+
+val check_constraints : constraints -> universes -> bool
+
+(** {6 Support for universe polymorphism } *)
+
+(** Polymorphic maps from universe levels to 'a *)
+module LMap : Map.S with type key = universe_level
+
+type 'a universe_map = 'a LMap.t
+
+(** {6 Substitution} *)
+
+type universe_subst_fn = universe_level -> universe
+type universe_level_subst_fn = universe_level -> universe_level
+
+(** A full substitution, might involve algebraic universes *)
+type universe_subst = universe universe_map
+type universe_level_subst = universe_level universe_map
+
+val level_subst_of : universe_subst_fn -> universe_level_subst_fn
+
+(** {6 Universe instances} *)
+
+module Instance :
+sig
+  type t
+  (** A universe instance represents a vector of argument universes
+      to a polymorphic definition (constant, inductive or constructor). *)
+
+  val empty : t
+  val is_empty : t -> bool
+
+  val equal : t -> t -> bool
+  (** Equality (note: instances are hash-consed, this is O(1)) *)
+
+  val subst_fn : universe_level_subst_fn -> t -> t
+  (** Substitution by a level-to-level function. *)
+
+  val subst : universe_level_subst -> t -> t
+  (** Substitution by a level-to-level function. *)
+
+  val pr : t -> Pp.std_ppcmds
+  (** Pretty-printing, no comments *)
+
+  val check_eq : t check_function
+  (** Check equality of instances w.r.t. a universe graph *)
+end
+
+type universe_instance = Instance.t
+
+type 'a puniverses = 'a * universe_instance
+
+(** A vector of universe levels with universe constraints,
+    representiong local universe variables and associated constraints *)
+
+module UContext :
+sig
+  type t
+
+  val empty : t
+
+  val instance : t -> Instance.t
+  val constraints : t -> constraints
+
+end
+
+module ContextSet :
+  sig 
+    type t
+    val empty : t
+    val constraints : t -> constraints
+  end
+
+type universe_context = UContext.t
+type universe_context_set = ContextSet.t
+
+val empty_level_subst : universe_level_subst
+val is_empty_level_subst : universe_level_subst -> bool
+
+(** Substitution of universes. *)
+val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level
+val subst_univs_level_universe : universe_level_subst -> universe -> universe
+
+(** Level to universe substitutions. *)
+
+val is_empty_subst : universe_subst -> bool
+val make_subst : universe_subst -> universe_subst_fn
+
+val subst_univs_universe : universe_subst_fn -> universe -> universe
+
+(** Substitution of instances *)
+val subst_instance_instance : universe_instance -> universe_instance -> universe_instance
+val subst_instance_universe : universe_instance -> universe -> universe
+val subst_instance_constraints : universe_instance -> constraints -> constraints
+
+(* val make_instance_subst : universe_instance -> universe_level_subst *)
+(* val make_inverse_instance_subst : universe_instance -> universe_level_subst *)
+
+(** Get the instantiated graph. *)
+val instantiate_univ_context : universe_context -> universe_context
+val instantiate_univ_constraints : universe_instance -> universe_context -> constraints
+
+(** {6 Pretty-printing of universes. } *)
+
+val pr_universes : universes -> Pp.std_ppcmds
diff --git a/checker/validate.ml b/checker/validate.ml
index 67baff73..63180f05 100644
--- a/checker/validate.ml
+++ b/checker/validate.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -36,32 +36,21 @@ let pr_obj o = pr_obj_rec o; Format.print_newline()
 (**************************************************************************)
 (* Obj low-level validators *)
 
-type error_context = string list
+type error_frame =
+| CtxAnnot of string
+| CtxType of string
+| CtxField of int
+| CtxTag of int
+
+type error_context = error_frame list
 let mt_ec : error_context = []
 let (/) (ctx:error_context) s : error_context = s::ctx
-let overr (ctx:error_context) f = (fun (_:error_context) -> f ctx) 
-let ext s f (ctx:error_context) = f (ctx/s)
-
 
 exception ValidObjError of string * error_context * Obj.t
 let fail ctx o s = raise (ValidObjError(s,ctx,o))
 
 type func = error_context -> Obj.t -> unit
 
-let apply debug f x =
-  let o = Obj.repr x in
-  try f mt_ec o
-  with ValidObjError(msg,ctx,obj) ->
-    if debug then begin
-      print_endline ("Validation failed: "^msg);
-      print_endline ("Context: "^String.concat"/"(List.rev ctx));
-      pr_obj obj
-    end;
-    failwith "vo structure validation failed"
-
-(* data not validated *)
-let no_val (c:error_context) (o:Obj.t) = ()
-
 (* Check that object o is a block with tag t *)
 let val_tag t ctx o =
   if Obj.is_block o && Obj.tag o = t then ()
@@ -73,36 +62,61 @@ let val_block ctx o =
       fail ctx o "block: found no scan tag")
   else fail ctx o "expected block obj"
 
-(* Check that an object is a tuple (or a record). v is an array of
-   validation functions for each field. Its size corresponds to the
+let val_dyn ctx o =
+  let fail () = fail ctx o "expected a Dyn.t" in
+  if not (Obj.is_block o) then fail ()
+  else if not (Obj.size o = 2) then fail ()
+  else if not (Obj.tag (Obj.field o 0) = Obj.int_tag) then fail ()
+  else ()
+
+open Values
+
+let rec val_gen v ctx o = match v with
+  | Tuple (name,vs) -> val_tuple ~name vs ctx o
+  | Sum (name,cc,vv) -> val_sum name cc vv ctx o
+  | Array v -> val_array v ctx o
+  | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] ctx o
+  | Opt v -> val_sum "option" 1 [|[|v|]|] ctx o
+  | Int -> if not (Obj.is_int o) then fail ctx o "expected an int"
+  | String ->
+    (try val_tag Obj.string_tag ctx o
+     with Failure _ -> fail ctx o "expected a string")
+  | Any -> ()
+  | Fail s -> fail ctx o ("unexpected object " ^ s)
+  | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o
+  | Dyn -> val_dyn ctx o
+
+(* Check that an object is a tuple (or a record). vs is an array of
+   value representation for each field. Its size corresponds to the
    expected size of the object. *)
-let val_tuple ?name v ctx o =
+and val_tuple ?name vs ctx o =
   let ctx = match name with
-      Some n -> ctx/n
-    | _ -> ctx in
-  let n = Array.length v in
-  let val_fld i f =
-    f (ctx/("fld="^string_of_int i)) (Obj.field o i) in
+    | Some n -> ctx/CtxType n
+    | _ -> ctx
+  in
+  let n = Array.length vs in
+  let val_fld i v =
+    val_gen v (ctx/(CtxField i)) (Obj.field o i) in
   val_block ctx o;
-  if Obj.size o = n then Array.iteri val_fld v
+  if Obj.size o = n then Array.iteri val_fld vs
   else
     fail ctx o
       ("tuple size: found "^string_of_int (Obj.size o)^
-	 ", expected "^string_of_int n)
+	  ", expected "^string_of_int n)
 
 (* Check that the object is either a constant constructor of tag < cc,
    or a constructed variant. each element of vv is an array of
-   validation functions to be applied to the constructor arguments.
+   value representations of the constructor arguments.
    The size of vv corresponds to the number of non-constant
    constructors, and the size of vv.(i) is the expected arity of the
    i-th non-constant constructor. *)
-let val_sum name cc vv ctx o =
-  let ctx = ctx/name in
+and val_sum name cc vv ctx o =
+  let ctx = ctx/CtxType name in
   if Obj.is_block o then
-    (val_block (ctx/name) o;
+    (val_block ctx o;
     let n = Array.length vv in
     let i = Obj.tag o in
-    let ctx' = if n=1 then ctx else ctx/("tag="^string_of_int i) in
+    let ctx' = if n=1 then ctx else ctx/CtxTag i in
     if i < n then val_tuple vv.(i) ctx' o
     else fail ctx' o ("sum: unexpected tag"))
   else if Obj.is_int o then
@@ -111,95 +125,27 @@ let val_sum name cc vv ctx o =
       fail ctx o ("bad constant constructor "^string_of_int n))
   else fail ctx o "not a sum"
 
-let val_enum s n = val_sum s n [||]
-
-(* Recursive types: avoid looping by eta-expansion *)
-let rec val_rec_sum name cc f ctx o =
-  val_sum name cc (f (overr (ctx/name) (val_rec_sum name cc f))) ctx o
-
-(**************************************************************************)
-(* Builtin types *)
-
 (* Check the o is an array of values satisfying f. *)
-let val_array ?(pos=false) f ctx o =
-  let upd_ctx =
-    if pos then (fun i -> ctx/string_of_int i) else (fun _ -> ctx) in
-  val_block (ctx/"array") o;
+and val_array v ctx o =
+  val_block (ctx/CtxType "array") o;
   for i = 0 to Obj.size o - 1 do
-    (f (upd_ctx i) (Obj.field o i):unit)
+    val_gen v ctx (Obj.field o i)
   done
 
-(* Integer validator *)
-let val_int ctx o =
-  if not (Obj.is_int o) then fail ctx o "expected an int"
-
-(* String validator *)
-let val_str ctx o =
-  try val_tag Obj.string_tag ctx o
-  with Failure _ -> fail ctx o "expected a string"
-
-(* Booleans *)
-let val_bool = val_enum "bool" 2
-
-(* Option type *)
-let val_opt ?(name="option") f =
-  val_sum name 1 [|[|f|]|]
-
-(* Lists *)
-let val_list ?(name="list") f ctx =
-  val_rec_sum name 1 (fun vlist -> [|[|ext "elem" f;vlist|]|])
-    ctx
-
-(* Reference *)
-let val_ref ?(name="ref") f ctx =
-  val_tuple [|f|] (ctx/name)
-
-(**************************************************************************)
-(* Standard library types *)
-
-(* Sets *)
-let val_set ?(name="Set.t") f =
-  val_rec_sum name 1
-    (fun vset -> [|[|vset;ext "elem" f;
-		     vset;ext "bal" val_int|]|])
-
-(* Maps *)
-let rec val_map ?(name="Map.t") fk fv =
-  val_rec_sum name 1
-    (fun vmap ->
-       [|[|vmap; ext "key" fk; ext "value" fv;
-	   vmap; ext "bal" val_int|]|])
-
-(**************************************************************************)
-(* Coq types *)
-
-(* names *)
-let val_id = val_str
-
-let val_dp = val_list ~name:"dirpath" val_id
-
-let val_name = val_sum "name" 1 [|[|val_id|]|]
-
-let val_uid = val_tuple ~name:"uniq_ident" [|val_int;val_str;val_dp|]
-
-let val_mp =
-  val_rec_sum "module_path" 0
-    (fun vmp -> [|[|val_dp|];[|val_uid|];[|vmp;val_id|]|])
-
-let val_kn = val_tuple ~name:"kernel_name" [|val_mp;val_dp;val_id|]
+let print_frame = function
+| CtxType t -> t
+| CtxAnnot t -> t
+| CtxField i -> Printf.sprintf "fld=%i" i
+| CtxTag i -> Printf.sprintf "tag=%i" i
 
-let val_con =
-  val_tuple ~name:"constant/mutind" [|val_kn;val_kn|]
-
-let val_ind = val_tuple ~name:"inductive"[|val_con;val_int|]
-let val_cstr = val_tuple ~name:"constructor"[|val_ind;val_int|]
-
-(* univ *)
-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 ~name:"Univ.constraints"
-   (val_tuple ~name:"univ_constraint"
-     [|val_level;val_enum "order_request" 3;val_level|])
+let validate debug v x =
+  let o = Obj.repr x in
+  try val_gen v mt_ec o
+  with ValidObjError(msg,ctx,obj) ->
+    if debug then begin
+      let ctx = List.rev_map print_frame ctx in
+      print_endline ("Validation failed: "^msg);
+      print_endline ("Context: "^String.concat"/"ctx);
+      pr_obj obj
+    end;
+    failwith "vo structure validation failed"
diff --git a/checker/values.ml b/checker/values.ml
new file mode 100644
index 00000000..3ca44b7d
--- /dev/null
+++ b/checker/values.ml
@@ -0,0 +1,350 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Abstract representations of values in a vo *)
+
+(** NB: UPDATE THIS FILE EACH TIME cic.mli IS MODIFIED !
+
+To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli
+with a copy we maintain here:
+
+MD5 0fbea8efeae581d87d977faa9eb2f421 checker/cic.mli
+
+*)
+
+(** We reify here the types of values present in a vo (see cic.mli),
+    in order to validate its structure. Maybe this reification
+    could become automatically generated someday ?
+
+    - [Any] stands for a value that we won't check,
+    - [Fail] means a value that shouldn't be there at all,
+    - [Tuple] provides a name and sub-values in this block
+    - [Sum] provides a name, a number of constant constructors,
+      and sub-values at each position of each possible constructed
+      variant
+    - [List] and [Opt] could have been defined via [Sum], but
+      having them here helps defining some recursive values below
+    - [Annot] is a no-op, just there for improving debug messages *)
+
+type value =
+  | Any
+  | Fail of string
+  | Tuple of string * value array
+  | Sum of string * int * value array array
+  | Array of value
+  | List of value
+  | Opt of value
+  | Int
+  | String
+  | Annot of string * value
+  | Dyn
+
+(** Some pseudo-constructors *)
+
+let v_tuple name v = Tuple(name,v)
+let v_sum name cc vv = Sum(name,cc,vv)
+let v_enum name n = Sum(name,n,[||])
+
+(** Ocaml standard library *)
+
+let v_pair v1 v2 = v_tuple "*" [|v1; v2|]
+let v_bool = v_enum "bool" 2
+let v_ref v = v_tuple "ref" [|v|]
+
+let v_set v =
+  let rec s = Sum ("Set.t",1,
+    [|[|s; Annot("elem",v); s; Annot("bal",Int)|]|])
+  in s
+
+let v_map vk vd =
+  let rec m = Sum ("Map.t",1,
+    [|[|m; Annot("key",vk); Annot("data",vd); m; Annot("bal",Int)|]|])
+  in m
+
+let v_hset v = v_map Int (v_set v)
+let v_hmap vk vd = v_map Int (v_map vk vd)
+
+(* lib/future *)
+let v_computation f =
+  Annot ("Future.computation",
+  v_ref
+    (v_sum "Future.comput" 0
+      [| [| Fail "Future.ongoing" |]; [| f |] |]))
+
+(** kernel/names *)
+
+let v_id = String
+let v_dp = Annot ("dirpath", List v_id)
+let v_name = v_sum "name" 1 [|[|v_id|]|]
+let v_uid = v_tuple "uniq_ident" [|Int;String;v_dp|]
+let rec v_mp = Sum("module_path",0,
+  [|[|v_dp|];
+    [|v_uid|];
+    [|v_mp;v_id|]|])
+let v_kn = v_tuple "kernel_name" [|Any;v_mp;v_dp;v_id;Int|]
+let v_cst = v_sum "cst|mind" 0 [|[|v_kn|];[|v_kn;v_kn|]|]
+let v_ind = v_tuple "inductive" [|v_cst;Int|]
+let v_cons = v_tuple "constructor" [|v_ind;Int|]
+
+
+(** kernel/univ *)
+
+let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) 
+  [|(*Level*)[|Int;v_dp|]; (*Var*)[|Int|]|]
+let v_level = v_tuple "level" [|Int;v_raw_level|] 
+let v_expr = v_tuple "levelexpr" [|v_level;Int|]
+let rec v_univ = Sum ("universe", 1, [| [|v_expr; Int; v_univ|] |])
+
+let v_cstrs =
+  Annot
+    ("Univ.constraints",
+     v_set
+       (v_tuple "univ_constraint"
+          [|v_level;v_enum "order_request" 3;v_level|]))
+
+let v_instance = Annot ("instance", Array v_level)
+let v_context = v_tuple "universe_context" [|v_instance;v_cstrs|]
+let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|]
+
+(** kernel/term *)
+
+let v_sort = v_sum "sort" 0 [|[|v_enum "cnt" 2|];[|v_univ|]|]
+let v_sortfam = v_enum "sorts_family" 3
+
+let v_puniverses v = v_tuple "punivs" [|v;v_instance|]
+
+let v_boollist = List v_bool  
+
+let v_caseinfo =
+  let v_cstyle = v_enum "case_style" 5 in
+  let v_cprint = v_tuple "case_printing" [|v_boollist;Array v_boollist;v_cstyle|] in
+  v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|]
+
+let v_cast = v_enum "cast_kind" 4
+
+let rec v_constr =
+  Sum ("constr",0,[|
+    [|Int|]; (* Rel *)
+    [|Fail "Var"|]; (* Var *)
+    [|Fail "Meta"|]; (* Meta *)
+    [|Fail "Evar"|]; (* Evar *)
+    [|v_sort|]; (* Sort *)
+    [|v_constr;v_cast;v_constr|]; (* Cast *)
+    [|v_name;v_constr;v_constr|]; (* Prod *)
+    [|v_name;v_constr;v_constr|]; (* Lambda *)
+    [|v_name;v_constr;v_constr;v_constr|]; (* LetIn *)
+    [|v_constr;Array v_constr|]; (* App *)
+    [|v_puniverses v_cst|]; (* Const *)
+    [|v_puniverses v_ind|]; (* Ind *)
+    [|v_puniverses v_cons|]; (* Construct *)
+    [|v_caseinfo;v_constr;v_constr;Array v_constr|]; (* Case *)
+    [|v_fix|]; (* Fix *)
+    [|v_cofix|]; (* CoFix *)
+    [|v_cst;v_constr|] (* Proj *)
+  |])
+
+and v_prec = Tuple ("prec_declaration",
+                    [|Array v_name; Array v_constr; Array v_constr|])
+and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|])
+and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|])
+
+
+let v_rdecl = v_tuple "rel_declaration" [|v_name;Opt v_constr;v_constr|]
+let v_rctxt = List v_rdecl
+
+let v_section_ctxt = v_enum "emptylist" 1
+
+
+(** kernel/mod_subst *)
+
+let v_delta_hint =
+  v_sum "delta_hint" 0 [|[|Int; Opt v_constr|];[|v_kn|]|]
+
+let v_resolver =
+  v_tuple "delta_resolver"
+    [|v_map v_mp v_mp;
+      v_hmap v_kn v_delta_hint|]
+
+let v_mp_resolver = v_tuple "" [|v_mp;v_resolver|]
+
+let v_subst =
+  v_tuple "substitution"
+    [|v_map v_mp v_mp_resolver;
+      v_map v_uid v_mp_resolver|]
+
+
+(** kernel/lazyconstr *)
+
+let v_substituted v_a =
+  v_tuple "substituted" [|v_a; List v_subst|]
+
+let v_cstr_subst = v_substituted v_constr
+
+(** NB: Second constructor [Direct] isn't supposed to appear in a .vo *)
+let v_lazy_constr =
+  v_sum "lazy_constr" 0 [|[|List v_subst;v_dp;Int|]|]
+
+
+(** kernel/declarations *)
+
+let v_engagement = v_enum "eng" 1
+
+let v_pol_arity =
+  v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|]
+
+let v_cst_type =
+  v_sum "constant_type" 0 [|[|v_constr|]; [|v_pair v_rctxt v_pol_arity|]|]
+
+let v_cst_def =
+  v_sum "constant_def" 0
+    [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|]
+
+let v_projbody =
+  v_tuple "projection_body" [|v_cst;Int;Int;v_constr;v_tuple "proj_eta" [|v_constr;v_constr|];
+			      v_constr|]
+
+let v_cb = v_tuple "constant_body"
+  [|v_section_ctxt;
+    v_cst_def;
+    v_cst_type;
+    Any;
+    v_bool;
+    v_context;
+    Opt v_projbody;
+    v_bool|]
+
+let v_recarg = v_sum "recarg" 1 (* Norec *)
+  [|[|v_ind|] (* Mrec *);[|v_ind|] (* Imbr *)|]
+
+let rec v_wfp = Sum ("wf_paths",0,
+    [|[|Int;Int|]; (* Rtree.Param *)
+      [|v_recarg;Array v_wfp|]; (* Rtree.Node *)
+      [|Int;Array v_wfp|] (* Rtree.Rec *)
+    |])
+
+let v_mono_ind_arity =
+  v_tuple "monomorphic_inductive_arity" [|v_constr;v_sort|]
+
+let v_ind_arity = v_sum "inductive_arity" 0
+  [|[|v_mono_ind_arity|];[|v_pol_arity|]|]
+
+let v_one_ind = v_tuple "one_inductive_body"
+  [|v_id;
+    v_rctxt;
+    v_ind_arity;
+    Array v_id;
+    Array v_constr;
+    Int;
+    Int;
+    List v_sortfam;
+    Array v_constr;
+    Array Int;
+    Array Int;
+    v_wfp;
+    Int;
+    Int;
+    Any|]
+
+let v_finite = v_enum "recursivity_kind" 3
+let v_mind_record = Annot ("mind_record", 
+			   Opt (Opt (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |])))
+
+let v_ind_pack = v_tuple "mutual_inductive_body"
+  [|Array v_one_ind;
+    v_mind_record;
+    v_finite;
+    Int;
+    v_section_ctxt;
+    Int;
+    Int;
+    v_rctxt;
+    v_bool;
+    v_context;
+    Opt v_bool|]
+
+let v_with =
+  Sum ("with_declaration_body",0,
+       [|[|List v_id;v_mp|];
+         [|List v_id;v_constr|]|])
+
+let rec v_mae =
+  Sum ("module_alg_expr",0,
+  [|[|v_mp|];         (* SEBident *)
+    [|v_mae;v_mp|];   (* SEBapply *)
+    [|v_mae;v_with|]  (* SEBwith *)
+  |])
+
+let rec v_sfb =
+  Sum ("struct_field_body",0,
+  [|[|v_cb|];       (* SFBconst *)
+    [|v_ind_pack|]; (* SFBmind *)
+    [|v_module|];   (* SFBmodule *)
+    [|v_modtype|]   (* SFBmodtype *)
+  |])
+and v_struc = List (Tuple ("label*sfb",[|v_id;v_sfb|]))
+and v_sign =
+  Sum ("module_sign",0,
+  [|[|v_struc|];                   (* NoFunctor *)
+    [|v_uid;v_modtype;v_sign|]|])  (* MoreFunctor *)
+and v_mexpr =
+  Sum ("module_expr",0,
+  [|[|v_mae|];                     (* NoFunctor *)
+    [|v_uid;v_modtype;v_mexpr|]|]) (* MoreFunctor *)
+and v_impl =
+  Sum ("module_impl",2, (* Abstract, FullStruct *)
+  [|[|v_mexpr|];  (* Algebraic *)
+    [|v_sign|]|])  (* Struct *)
+and v_noimpl = v_enum "no_impl" 1 (* Abstract is mandatory for mtb *)
+and v_module =
+  Tuple ("module_body",
+         [|v_mp;v_impl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|])
+and v_modtype =
+  Tuple ("module_type_body",
+         [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|])
+
+(** kernel/safe_typing *)
+
+let v_vodigest = Sum ("module_impl",0, [| [|String|]; [|String;String|] |])
+let v_deps = Array (v_tuple "dep" [|v_dp;v_vodigest|])
+let v_compiled_lib =
+  v_tuple "compiled" [|v_dp;v_module;v_deps;Opt v_engagement;Any|]
+
+(** Library objects *)
+
+let v_obj = Dyn
+let v_libobj = Tuple ("libobj", [|v_id;v_obj|])
+let v_libobjs = List v_libobj
+let v_libraryobjs = Tuple ("library_objects",[|v_libobjs;v_libobjs|])
+
+(** Toplevel structures in a vo (see Cic.mli) *)
+
+let v_lib =
+  Tuple ("library",[|v_dp;v_compiled_lib;v_libraryobjs;v_deps;Array v_dp|])
+
+let v_opaques = Array (v_computation v_constr)
+let v_univopaques =
+  Opt (Tuple ("univopaques",[|Array (v_computation v_context_set);v_context_set;v_bool|]))
+
+(** Registering dynamic values *)
+
+module StringOrd =
+struct
+  type t = string
+  let compare (x : t) (y : t) = compare x y
+end
+
+module StringMap = Map.Make(StringOrd)
+
+let dyn_table : value StringMap.t ref = ref StringMap.empty
+
+let register_dyn name t =
+  dyn_table := StringMap.add name t !dyn_table
+
+let find_dyn name =
+  try StringMap.find name !dyn_table
+  with Not_found -> Any
diff --git a/checker/votour.ml b/checker/votour.ml
new file mode 100644
index 00000000..29593cb7
--- /dev/null
+++ b/checker/votour.ml
@@ -0,0 +1,189 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Values
+
+(** {6 Interactive visit of a vo} *)
+
+(** Name of a value *)
+
+type dyn = { dyn_tag : string; dyn_obj : Obj.t; }
+
+let to_dyn obj = (Obj.magic obj : dyn)
+
+let rec get_name ?(extra=false) = function
+  |Any -> "?"
+  |Fail s -> "Invalid node: "^s
+  |Tuple (name,_) -> name
+  |Sum (name,_,_) -> name
+  |Array v -> "array"^(if extra then "/"^get_name ~extra v else "")
+  |List v -> "list"^(if extra then "/"^get_name ~extra v else "")
+  |Opt v -> "option"^(if extra then "/"^get_name ~extra v else "")
+  |Int -> "int"
+  |String -> "string"
+  |Annot (s,v) -> s^"/"^get_name ~extra v
+  |Dyn -> "<dynamic>"
+
+(** For tuples, its quite handy to display the inner 1st string (if any).
+    Cf. [structure_body] for instance *)
+
+let get_string_in_tuple v o =
+  try
+    for i = 0 to Array.length v - 1 do
+      if v.(i) = String then
+        failwith (" [.."^(Obj.magic (Obj.field o i) : string)^"..]");
+    done;
+    ""
+  with Failure s -> s
+
+(** Some details : tags, integer value for non-block, etc etc *)
+
+let rec get_details v o = match v with
+  |String | Any when (Obj.is_block o && Obj.tag o = Obj.string_tag) ->
+    " [" ^ String.escaped (Obj.magic o : string) ^"]"
+  |Tuple (_,v) -> get_string_in_tuple v o
+  |(Sum _|Any) when Obj.is_block o ->
+    " [tag=" ^ string_of_int (Obj.tag o) ^"]"
+  |(Sum _|Any) ->
+    " [imm=" ^ string_of_int (Obj.magic o : int) ^"]"
+  |Int -> " [" ^ string_of_int (Obj.magic o : int) ^"]"
+  |Annot (s,v) -> get_details v o
+  |_ -> ""
+
+let node_info (v,o,p) =
+  get_name ~extra:true v ^ get_details v o ^
+    " (size "^ string_of_int (CObj.shared_size_of_pos p)^"w)"
+
+(** Children of a block : type, object, position.
+    For lists, we collect all elements of the list at once *)
+
+let access_children vs o pos =
+  Array.mapi (fun i v -> v, Obj.field o i, i::pos) vs
+
+let rec get_children v o pos = match v with
+  |Tuple (_,v) -> access_children v o pos
+  |Sum (_,_,vv) ->
+    if Obj.is_block o then access_children vv.(Obj.tag o) o pos
+    else [||]
+  |Array v -> access_children (Array.make (Obj.size o) v) o pos
+  |List v ->
+    let rec loop pos = function
+      | [] -> []
+      | o :: ol -> (v,o,0::pos) :: loop (1::pos) ol
+    in
+    Array.of_list (loop pos (Obj.magic o : Obj.t list))
+  |Opt v ->
+    if Obj.is_block o then [|v,Obj.field o 0,0::pos|] else [||]
+  |String | Int -> [||]
+  |Annot (s,v) -> get_children v o pos
+  |Any ->
+    if Obj.is_block o && Obj.tag o < Obj.no_scan_tag then
+      Array.init (Obj.size o) (fun i -> (Any,Obj.field o i,i::pos))
+    else [||]
+  |Dyn ->
+    let t = to_dyn o in
+    let tpe = find_dyn t.dyn_tag in
+    [|(String, Obj.repr t.dyn_tag, 0 :: pos); (tpe, t.dyn_obj, 1 :: pos)|]
+  |Fail s -> failwith "forbidden"
+
+type info = {
+  nam : string;
+  typ : value;
+  obj : Obj.t;
+  pos : int list
+}
+
+let stk = ref ([] : info list)
+
+let init () = stk := []
+
+let push name v o p = stk := { nam = name; typ = v; obj = o; pos = p } :: !stk
+
+let pop () = match !stk with
+  | i::s -> stk := s; i
+  | _ -> failwith "empty stack"
+
+let rec visit v o pos =
+  Printf.printf "\nDepth %d Pos %s Context %s\n"
+    (List.length !stk)
+    (String.concat "." (List.rev_map string_of_int pos))
+    (String.concat "/" (List.rev_map (fun i -> i.nam) !stk));
+  Printf.printf "-------------\n";
+  let children = get_children v o pos in
+  let nchild = Array.length children in
+  Printf.printf "Here: %s, %d child%s\n"
+    (node_info (v,o,pos)) nchild (if nchild = 0 then "" else "ren:");
+  Array.iteri
+    (fun i vop -> Printf.printf "  %d: %s\n" i (node_info vop))
+    children;
+  Printf.printf "-------------\n";
+  Printf.printf ("# %!");
+  let l = read_line () in
+  try
+    if l = "u" then let info = pop () in visit info.typ info.obj info.pos
+    else if l = "x" then (Printf.printf "\nGoodbye!\n\n";exit 0)
+    else
+      let v',o',pos' = children.(int_of_string l) in
+      push (get_name v) v o pos;
+      visit v' o' pos'
+  with
+  | Failure "empty stack" -> ()
+  | Failure "forbidden" -> let info = pop () in visit info.typ info.obj info.pos
+  | Failure _ | Invalid_argument _ -> visit v o pos
+
+(** Loading the vo *)
+
+type segment = {
+  name : string;
+  mutable pos : int;
+  typ : Values.value;
+}
+
+let visit_vo f =
+  Printf.printf "\nWelcome to votour !\n";
+  Printf.printf "Enjoy your guided tour of a Coq .vo or .vi file\n";
+  Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size;
+  Printf.printf
+    "At prompt, <n> enters the <n>-th child, u goes up 1 level, x exits\n\n%!";
+  let segments = [|
+    {name="library"; pos=0; typ=Values.v_lib};
+    {name="univ constraints of opaque proofs"; pos=0;typ=Values.v_univopaques}; 
+    {name="discharging info"; pos=0; typ=Opt Any};
+    {name="STM tasks"; pos=0; typ=Opt Any};
+    {name="opaque proofs"; pos=0; typ=Values.v_opaques}; 
+  |] in
+  while true do
+    let ch = open_in_bin f in
+    let magic = input_binary_int ch in
+    Printf.printf "File format: %d\n%!" magic;
+    for i=0 to Array.length segments - 1 do
+      let pos = input_binary_int ch in
+      segments.(i).pos <- pos_in ch;
+      seek_in ch pos;
+      ignore(Digest.input ch);
+    done;
+    Printf.printf "The file has %d segments, choose the one to visit:\n"
+      (Array.length segments);
+    Array.iteri (fun i { name; pos } ->
+      Printf.printf "  %d: %s, starting at byte %d\n" i name pos)
+      segments;
+    Printf.printf "# %!";
+    let l = read_line () in
+    let seg = int_of_string l in
+    seek_in ch segments.(seg).pos;
+    let o = (input_value ch : Obj.t) in
+    let () = CObj.register_shared_size o in
+    let () = init () in
+    visit segments.(seg).typ o []
+  done
+
+let main =
+  if not !Sys.interactive then
+    Arg.parse [] visit_vo
+      ("votour: guided tour of a Coq .vo or .vi file\n"^
+       "Usage: votour file.v[oi]")